procedure TForm1.ListBox1DrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
begin
inherited;
TListBox(Control).Canvas.FillRect(Rect);
TListBox(Control).Canvas.TextOut(Rect.Left+5, Rect.Top+8, TListBox(Control).Items[Index]);
if odSelected in State then
begin
Button.Left:=Rect.Right-80;
Button.Top:=Rect.Top+4;
Button.Visible:=true;
Button.Invalidate;
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
ListBox1.DoubleBuffered:=true;
ListBox1.ItemHeight:=30;
ListBox1.Style:=lbOwnerDrawFixed;
Button:=TButton.Create(ListBox1);
Button.Parent:=ListBox1;
Button.DoubleBuffered:=true;
Button.Visible:=false;
Button.Width:=50;
Button.Height:=20;
Button.Caption:='BTN';
end;
The repaint problem only exists when using ScrollBar or sending WM_VSCROLL message to my ListBox. All normally drawn when I change selection by using keyboard arrows or mouse clicks. Problem also not exists when selected item are visible by scrolling and not leave visible area.
I think that Button.Top property still have an old value before DrawItem calls, and change (to -30px for example) later.
The problem is that you are using the OnDrawItem event to make changes to the UI (in this case, positioning the button). Do not do that, the event is for DRAWING ONLY.
I would suggest that you either:
subclass the ListBox to handle the WM_VSCROLL message and have your message handler reposition the button as needed.
var
PrevListBoxWndProc: TWndMethod;
procedure TForm1.FormCreate(Sender: TObject);
begin
PrevListBoxWndProc := ListBox1.WindowProc;
ListBox1.WindowProc := ListBoxWndProc;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
ListBox1.WindowProc := PrevListBoxWndProc;
end;
procedure TForm1.PositionButton(Index: Integer);
var
R: TRect;
begin
if Index <= -1 then
Button.Visible := False
else
begin
R := ListBox1.ItemRect(Index);
Button.Left := R.Right - 80;
Button.Top := R.Top + 4;
Button.Visible := True;
end;
end;
var
LastIndex: Integer = -1;
procedure TForm1.ListBox1Click(Sender: TObject);
var
Index: Integer;
begin
Index := ListBox1.ItemIndex;
if Index <> LastIndex then
begin
LastIndex := Index;
PositionButton(Index);
end;
end;
procedure TForm1.ListBoxWndProc(var Message: TMessage);
begin
PrevListBoxWndProc(Message);
if Message.Msg = WM_VSCROLL then
PositionButton(ListBox1.ItemIndex);
end;
get rid of the TButton altogether. Use OnDrawItem to draw an image of a button (you can use DrawFrameControl() or DrawThemeBackground() for that) directly onto the ListBox, and then use the OnMouseDown/Up or OnClick event to check if the mouse is over the "button" and if so act accordingly as needed.
var
MouseX: Integer = -1;
MouseY: Integer = -1;
procedure TForm1.ListBox1DrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
var
R: TRect;
P: TPoint;
BtnState: UINT;
begin
TListBox(Control).Canvas.FillRect(Rect);
TListBox(Control).Canvas.TextOut(Rect.Left+5, Rect.Top+8, TListBox(Control).Items[Index]);
if not (odSelected in State) then Exit;
R := Rect(Rect.Right-80, Rect.Top+4, Rect.Right-30, Rect.Top+24);
P := Point(MouseX, MouseY);
BtnState := DFCS_BUTTONPUSH;
if PtInRect(R, P) then BtnState := BtnState or DFCS_PUSHED;
DrawFrameControl(TListBox(Control).Canvas.Handle, R, DFC_BUTTON, BtnState);
InflateRect(R, -4, -4);
DrawText(TListBox(Control).Canvas.Handle, 'BTN', 3, R, DT_CENTER or DT_VCENTER or DT_SINGLELINE);
end;
procedure TForm1.ListBox1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if Button <> mbLeft then Exit;
MouseX := X;
MouseY := Y;
ListBox1.Invalidate;
end;
procedure TForm1.ListBox1MouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if Button <> mbLeft then Exit;
MouseX := -1;
MouseY := -1;
ListBox1.Invalidate;
end;
procedure TForm1.ListBox1Click(Sender: TObject);
var
P: TPoint;
R: TRect;
Index: Integer;
begin
P := Point(MouseX, MouseY);
Index := ListBox1.ItemAtPos(P, True);
if (Index = -1) or (Index <> ListBox1.ItemIndex) then Exit;
R := ListBox1.ItemRect(Index);
R := Rect(R.Right-80, R.Top+4, R.Right-30, R.Top+24);
if not PtInRect(R, P) then Exit;
// click is on selected item's "button", do something...
end;
Related
I am trying to make an app where the cells of a TStringGrid will change color when I click on them. Each time I click on a cell, it should switch over to the next color and stay that color, until I click on that cell again, in order:
white ==> red ==> orange ==> green ==> white (like a traffic light).
The error(s) I am getting is a bit hard to explain, but I'll try.
The application runs, but when I click on one cell and then on another, sometimes the first cell I clicked on changes color, but the second one doesn't. Other times, both cells change color. Other times, both cells just reset to their white state.
type
TForm1 = class(TForm)
StringGrid: TStringGrid;
procedure StringGridDrawCell(Sender: TObject; ACol, ARow: Integer;
Rect: TRect; State: TGridDrawState);
private
arrState: array[1..4, 1..4] of Integer;
end;
procedure TForm1.StringGridDrawCell(Sender: TObject; ACol, ARow: Integer;
Rect: TRect; State: TGridDrawState);
var
iRow, iCol: Integer;
arrk: array[1..4, 1..4] of Integer;
begin
for iCol := 4 downto 1 do
begin
for iRow := 4 downto 1 do
begin
if (gdSelected in State) then
begin
case arrState[ARow, aCol] of
0: begin
StringGrid.Canvas.Brush.Color := clWhite;
Rect := StringGrid.CellRect(iCol, iRow);
StringGrid.Canvas.FillRect(Rect);
Inc(arrState[iRow, iCol]);
end;
1: begin
StringGrid.Canvas.Brush.Color := clRed;
Rect := StringGrid.CellRect(iCol, iRow);
StringGrid.Canvas.FillRect(Rect);
Inc(arrState[iRow, iCol]);
end;
2: begin
StringGrid.Canvas.Brush.Color := $008CFF;
Rect := StringGrid.CellRect(iCol, iRow);
StringGrid.Canvas.FillRect(Rect);
Inc(arrState[iRow, iCol]);
end;
3: begin
StringGrid.Canvas.Brush.Color := clGreen;
Rect := StringGrid.CellRect(iCol, iRow);
StringGrid.Canvas.FillRect(Rect);
arrState[iRow, iCol] := 0;
end;
end;
end;
end;
end;
end;
The problem is that you are using the OnDrawCell event to update your state machine. NEVER use a drawing event to drive state changes! A UI control gets painted often and for many reasons, so any drawing events should be painting only the current state, for the specific item that is currently being drawn. You should be using the OnSelectCell or OnClick event to update your state machine and then trigger a repaint of the updated cell.
Try this:
type
TForm1 = class(TForm)
StringGrid: TStringGrid;
procedure StringGridDrawCell(Sender: TObject; ACol, ARow: Integer;
Rect: TRect; State: TGridDrawState);
procedure StringGridSelectCell(Sender: TObject; ACol, ARow: Integer;
var CanSelect: Boolean);
private
arrState: array[1..4, 1..4] of Integer;
end;
procedure TForm1.StringGridDrawCell(Sender: TObject; ACol, ARow: Integer;
Rect: TRect; State: TGridDrawState);
const
clOrange = TColor($008CFF);
CellColors: array[0..3] of TColor = (clWhite, clRed, clOrange, clGreen);
begin
if (ACol in [1..4]) and (ARow in [1..4]) then
begin
StringGrid.Canvas.Brush.Color := CellColors[arrState[ARow, ACol]];
StringGrid.Canvas.FillRect(Rect);
end;
end;
// TStringGrid.InvalidateCell() is protected,
// but can be reached using an accessor class..
type
TStringGridAccess = class(TStringGrid)
end;
procedure TForm1.StringGridSelectCell(Sender: TObject; ACol, ARow: Integer;
var CanSelect: Boolean);
begin
if (ACol in [1..4]) and (ARow in [1..4]) then
begin
arrState[ARow, ACol] := (arrState[ARow, ACol] + 1) mod 4;
TStringGridAccess(StringGrid).InvalidateCell(ACol, ARow);
end;
end;
Alternatively:
type
TForm1 = class(TForm)
StringGrid: TStringGrid;
procedure StringGridClick(Sender: TObject);
procedure StringGridDrawCell(Sender: TObject; ACol, ARow: Integer;
Rect: TRect; State: TGridDrawState);
private
arrState: array[1..4, 1..4] of Integer;
end;
// TStringGrid.InvalidateCell() is protected,
// but can be reached using an accessor class..
type
TStringGridAccess = class(TStringGrid)
end;
procedure TForm1.StringGridClick(Sender: TObject);
type
POINTS = packed record
x: SHORT;
y: SHORT;
end;
var
dwPos: DWORD;
pts: POINTS absolute dwPos;
pt: TPoint;
iCol, iRow: Integer;
begin
dwPos := GetMessagePos();
pt := StringGrid.ScreenToClient(Point(pts.x, pts.y));
StringGrid.MouseToCell(pt.X, pt.Y, iCol, iRow);
if (iCol in [1..4]) and (iRow in [1..4]) then
begin
arrState[iRow, iCol] := (arrState[iRow, iCol] + 1) mod 4;
TStringGridAccess(StringGrid).InvalidateCell(iCol, iRow);
end;
end;
procedure TForm1.StringGridDrawCell(Sender: TObject; ACol, ARow: Integer;
Rect: TRect; State: TGridDrawState);
const
clOrange = TColor($008CFF);
CellColors: array[0..3] of TColor = (clWhite, clRed, clOrange, clGreen);
begin
if (ACol in [1..4]) and (ARow in [1..4]) then
begin
StringGrid.Canvas.Brush.Color := CellColors[arrState[ARow, ACol]];
StringGrid.Canvas.FillRect(Rect);
end;
end;
I want to have a button with icon at the end of each row.
Like here:
I tried this
procedure TMyFrame.sgrd1DrawCell(Sender: TObject; ACol,
ARow: Integer; Rect: TRect; State: TGridDrawState);
var
canvas: TCanvas;
sgrd: TStringGrid;
point: TPoint;
btn: TSpeedButton;
begin
sgrd := TStringGrid(Sender);
canvas := sgrd.Canvas;
canvas.FillRect(Rect);
if (ACol = 1) then
begin
point := Self.ScreenToClient(ClientToScreen(Rect.TopLeft));
btn := TSpeedButton.Create(sgrd);
btn.Parent := sgrd;
btn.OnClick := SpeedButton1Click;
btn.Tag := ARow;
btn.enabled:=true;
btn.visible:= true;
btn.Top := point.Y;
btn.Left := point.X;
btn.Width := 20;
btn.Height := 24;
end;
end;
but the button doesn't look like "alive" although click event works. No click, hover animation, focus, etc.
Assuming you might want to be able to scroll within your StringGrid and have the Buttons beeing associated with the selected row, you will have to implement an handler for TopLeftChanged. The buttons won't be moved if you scroll in your Stringgrid, without implementing code for this.
procedure TForm3.SpeedButton1Click(Sender: TObject);
begin
Showmessage(TSpeedButton(Sender).Name + ' ' + IntToStr(TSpeedButton(Sender).Tag));
end;
const
C_COL = 4;
procedure TForm3.StringGrid1TopLeftChanged(Sender: TObject);
var
point: TPoint;
btn: TSpeedButton;
row: integer;
rect: TRect;
y: integer;
begin
rect := TStringGrid(Sender).CellRect(C_COL, TStringGrid(Sender).TopRow);
point := ScreenToClient(ClientToScreen(rect.TopLeft));
y := rect.Top;
for row := 0 to TStringGrid(Sender).RowCount - 1 do
begin
btn := TSpeedButton(TStringGrid(Sender).FindComponent(Format('SP%d', [row])));
if row >= TStringGrid(Sender).TopRow then
begin
btn.Top := y;
btn.Left := rect.Left;
btn.Visible := rect.Right > 0;
y := y + TStringGrid(Sender).DefaultRowHeight;
end
else
btn.Visible := false;
end;
end;
procedure TForm3.FormCreate(Sender: TObject);
var
point: TPoint;
btn: TSpeedButton;
row: integer;
rect: TRect;
y: integer;
begin
rect := StringGrid1.CellRect(C_COL, StringGrid1.TopRow);
point := ScreenToClient(ClientToScreen(rect.TopLeft));
y := rect.Top;
for row := 0 to StringGrid1.RowCount - 1 do
begin
btn := TSpeedButton.Create(StringGrid1);
btn.Name := Format('SP%d', [row]);
btn.Parent := StringGrid1;
btn.OnClick := SpeedButton1Click;
btn.tag := row;
btn.Width := StringGrid1.ColWidths[C_COL];
btn.Height := StringGrid1.DefaultRowHeight;
btn.Visible := false;
end;
StringGrid1TopLeftChanged(TStringGrid(Sender));
end;
an enhanced version as suggested by #Tlama would make it necessary to implement an interposer class or use an own component to override ColWidthsChanged and RowHeightsChanged to keep the buttons painted correct not just on scrolling but on row/column sizing.
//.....
type
TStringGrid=Class(Grids.TStringGrid)
procedure ColWidthsChanged; override;
procedure RowHeightsChanged; override;
End;
TForm3 = class(TForm)
StringGrid1: TStringGrid;
SpeedButton1: TSpeedButton;
procedure FormCreate(Sender: TObject);
procedure StringGrid1TopLeftChanged(Sender: TObject);
private
procedure SpeedButton1Click(Sender: TObject);
{ Private-Deklarationen }
public
{ Public-Deklarationen }
end;
var
Form3: TForm3;
implementation
{$R *.dfm}
{ TStringGrid }
procedure TStringGrid.ColWidthsChanged;
begin
inherited;
TopLeftChanged;
end;
procedure TStringGrid.RowHeightsChanged;
begin
inherited;
TopLeftChanged;
end;
procedure TForm3.SpeedButton1Click(Sender: TObject);
begin
Showmessage(TSpeedButton(Sender).Name + ' ' + IntToStr(TSpeedButton(Sender).Tag));
end;
const
C_COL = 4;
procedure TForm3.StringGrid1TopLeftChanged(Sender: TObject);
var
point: TPoint;
btn: TSpeedButton;
row: integer;
rect: TRect;
y: integer;
begin
for row := 0 to TStringGrid(Sender).RowCount - 1 do
begin
btn := TSpeedButton(TStringGrid(Sender).FindComponent(Format('SP%d', [row])));
if row >= TStringGrid(Sender).TopRow then
begin
rect := TStringGrid(Sender).CellRect(C_COL, row);
btn.BoundsRect := rect;
btn.Visible := rect.Right > 0;
y := y + TStringGrid(Sender).DefaultRowHeight;
end
else
btn.Visible := false;
end;
end;
procedure TForm3.FormCreate(Sender: TObject);
var
point: TPoint;
btn: TSpeedButton;
row: integer;
rect: TRect;
y: integer;
begin
rect := StringGrid1.CellRect(C_COL, StringGrid1.TopRow);
point := ScreenToClient(ClientToScreen(rect.TopLeft));
y := rect.Top;
for row := 0 to StringGrid1.RowCount - 1 do
begin
btn := TSpeedButton.Create(StringGrid1);
btn.Name := Format('SP%d', [row]);
btn.Parent := StringGrid1;
btn.OnClick := SpeedButton1Click;
btn.tag := row;
btn.Visible := false;
end;
StringGrid1TopLeftChanged(TStringGrid(Sender));
end;
procedure TForm1.FormCreate(Sender: TObject);
var
Canvas: TCanvas;
Point: TPoint;
MySpeedBtn: TSpeedButton;
Row: integer;
Rect: TRect;
begin
for Row := 1 to StringGrid1.RowCount - 1 do
begin
Rect := StringGrid1.CellRect(4, Row);
point := ScreenToClient(ClientToScreen(Rect.TopLeft));
MySpeedBtn := TSpeedButton.Create(StringGrid1);
MySpeedBtn.Parent := StringGrid1;
MySpeedBtn.OnClick := SpeedButton1Click;
MySpeedBtn.Tag := Row;
MySpeedBtn.Width := 20;
MySpeedBtn.Height := StringGrid1.RowHeights[1];
MySpeedBtn.Top := Point.Y;
MySpeedBtn.Left := Point.X + StringGrid1.ColWidths[1] - MySpeedBtn.Width;
end;
end;
The problem is that you are continuously creating a new speedbutton every time the cell needs refreshing. You must create the buttons in the Create event.
procedure TForm1.FormCreate(Sender: TObject);
var
canvas: TCanvas;
point: TPoint;
btn: TSpeedButton;
row : integer;
rect: TRect;
begin
for row:=0 to stringGrid1.RowCount-1 do
begin
rect := stringGrid1.CellRect(1,row);
point := ScreenToClient(ClientToScreen(Rect.TopLeft));
btn := TSpeedButton.Create(StringGrid1);
btn.Parent := StringGrid1;
btn.OnClick := SpeedButton1Click;
btn.Tag := row;
btn.enabled:=true;
btn.visible:= true;
btn.Top := point.Y;
btn.Left := point.X;
btn.Width := 20;
btn.Height := 24;
end;
I have a ListView with 3 columns and would like to edit the third column, aka Subitem[1]. If I set ListView.ReadOnly to False, it allows me to edit the caption of the selected item. Is there an easy way to do the same thing for the subitem? I would like to stay away from adding a borderless control on top that does the editing.
You can Edit a subitem of the listview (in report mode) using a TEdit, a custom message and handling the OnClick event of the ListView.
Try this sample
Const
USER_EDITLISTVIEW = WM_USER + 666;
type
TForm1 = class(TForm)
ListView1: TListView;
procedure FormCreate(Sender: TObject);
procedure ListView1Click(Sender: TObject);
private
ListViewEditor: TEdit;
LItem: TListitem;
procedure UserEditListView( Var Message: TMessage ); message USER_EDITLISTVIEW;
procedure ListViewEditorExit(Sender: TObject);
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
uses
CommCtrl;
const
EDIT_COLUMN = 2; //Index of the column to Edit
procedure TForm1.FormCreate(Sender: TObject);
Var
I : Integer;
Item : TListItem;
begin
for I := 0 to 9 do
begin
Item:=ListView1.Items.Add;
Item.Caption:=Format('%d.%d',[i,1]);
Item.SubItems.Add(Format('%d.%d',[i,2]));
Item.SubItems.Add(Format('%d.%d',[i,3]));
end;
//create the TEdit and assign the OnExit event
ListViewEditor:=TEdit.Create(Self);
ListViewEditor.Parent:=ListView1;
ListViewEditor.OnExit:=ListViewEditorExit;
ListViewEditor.Visible:=False;
end;
procedure TForm1.ListView1Click(Sender: TObject);
var
LPoint: TPoint;
LVHitTestInfo: TLVHitTestInfo;
begin
LPoint:= listview1.ScreenToClient(Mouse.CursorPos);
ZeroMemory( #LVHitTestInfo, SizeOf(LVHitTestInfo));
LVHitTestInfo.pt := LPoint;
//Check if the click was made in the column to edit
If (ListView1.perform( LVM_SUBITEMHITTEST, 0, LPARAM(#LVHitTestInfo))<>-1) and ( LVHitTestInfo.iSubItem = EDIT_COLUMN ) Then
PostMessage( self.Handle, USER_EDITLISTVIEW, LVHitTestInfo.iItem, 0 )
else
ListViewEditor.Visible:=False; //hide the TEdit
end;
procedure TForm1.ListViewEditorExit(Sender: TObject);
begin
If Assigned(LItem) Then
Begin
//assign the vslue of the TEdit to the Subitem
LItem.SubItems[ EDIT_COLUMN-1 ] := ListViewEditor.Text;
LItem := nil;
End;
end;
procedure TForm1.UserEditListView(var Message: TMessage);
var
LRect: TRect;
begin
LRect.Top := EDIT_COLUMN;
LRect.Left:= LVIR_BOUNDS;
listview1.Perform( LVM_GETSUBITEMRECT, Message.wparam, LPARAM(#LRect) );
MapWindowPoints( listview1.Handle, ListViewEditor.Parent.Handle, LRect, 2 );
//get the current Item to edit
LItem := listview1.Items[ Message.wparam ];
//set the text of the Edit
ListViewEditor.Text := LItem.Subitems[ EDIT_COLUMN-1];
//set the bounds of the TEdit
ListViewEditor.BoundsRect := LRect;
//Show the TEdit
ListViewEditor.Visible:=True;
end;
I wrote sample code on CodeCentral that shows how to do this.
How to use the Build-in Editor of TListView to Edit SubItems
Update:
Here is an updated version that should compile now:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics,
Controls, Forms, Dialogs, ComCtrls;
type
TForm1 = class(TForm)
ListView1: TListView;
procedure ListView1Editing(Sender: TObject; Item: TListItem; var AllowEdit: Boolean);
procedure ListView1Edited(Sender: TObject; Item: TListItem; var S: string);
procedure ListView1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
procedure ListView1DrawItem(Sender: TCustomListView; Item: TListItem; Rect: TRect; State: TOwnerDrawState);
private
{ Private declarations }
ColumnToEdit: Integer;
OldListViewEditProc: Pointer;
hListViewEditWnd: HWND;
ListViewEditWndProcPtr: Pointer;
procedure ListViewEditWndProc(var Message: TMessage);
public
{ Public declarations }
constructor Create(Owner: TComponent); override;
destructor Destroy; override;
end;
var
Form1: TForm1;
implementation
uses
Commctrl;
{$R *.dfm}
type
TListViewCoord = record
Item: Integer;
Column: Integer;
end;
TLVGetColumnAt = function(Item: TListItem; const Pt: TPoint): Integer;
TLVGetColumnRect = function(Item: TListItem; ColumnIndex: Integer; var Rect: TRect): Boolean;
TLVGetIndexesAt = function(ListView: TCustomListView; const Pt: TPoint; var Coord: TListViewCoord): Boolean;
// TCustomListViewAccess provides access to the protected members of TCustomListView
TCustomListViewAccess = class(TCustomListView);
var
// these will be assigned according to the version of COMCTL32.DLL being used
GetColumnAt: TLVGetColumnAt = nil;
GetColumnRect: TLVGetColumnRect = nil;
GetIndexesAt: TLVGetIndexesAt = nil;
//---------------------------------------------------------------------------
// GetComCtl32Version
//
// Purpose: Helper function to determine the version of CommCtrl32.dll that is loaded.
//---------------------------------------------------------------------------
var
ComCtl32Version: DWORD = 0;
function GetComCtl32Version: DWORD;
type
DLLVERSIONINFO = packed record
cbSize: DWORD;
dwMajorVersion: DWORD;
dwMinorVersion: DWORD;
dwBuildNumber: DWORD;
dwPlatformID: DWORD;
end;
DLLGETVERSIONPROC = function(var dvi: DLLVERSIONINFO): Integer; stdcall;
var
hComCtrl32: HMODULE;
lpDllGetVersion: DLLGETVERSIONPROC;
dvi: DLLVERSIONINFO;
FileName: array[0..MAX_PATH] of Char;
dwHandle: DWORD;
dwSize: DWORD;
pData: Pointer;
pVersion: Pointer;
uiLen: UINT;
begin
if ComCtl32Version = 0 then
begin
hComCtrl32 := GetModuleHandle('comctl32.dll');
if hComCtrl32 <> 0 then
begin
#lpDllGetVersion := GetProcAddress(hComCtrl32, 'DllGetVersion');
if #lpDllGetVersion <> nil then
begin
ZeroMemory(#dvi, SizeOf(dvi));
dvi.cbSize := SizeOf(dvi);
if lpDllGetVersion(dvi) >= 0 then
ComCtl32Version := MAKELONG(Word(dvi.dwMinorVersion), Word(dvi.dwMajorVersion));
end;
if ComCtl32Version = 0 then
begin
ZeroMemory(#FileName[0], SizeOf(FileName));
if GetModuleFileName(hComCtrl32, FileName, MAX_PATH) <> 0 then
begin
dwHandle := 0;
dwSize := GetFileVersionInfoSize(FileName, dwHandle);
if dwSize <> 0 then
begin
GetMem(pData, dwSize);
try
if GetFileVersionInfo(FileName, dwHandle, dwSize, pData) then
begin
pVersion := nil;
uiLen := 0;
if VerQueryValue(pData, '\', pVersion, uiLen) then
begin
with PVSFixedFileInfo(pVersion)^ do
ComCtl32Version := MAKELONG(LOWORD(dwFileVersionMS), HIWORD(dwFileVersionMS));
end;
end;
finally
FreeMem(pData);
end;
end;
end;
end;
end;
end;
Result := ComCtl32Version;
end;
//---------------------------------------------------------------------------
// Manual_GetColumnAt
//
// Purpose: Returns the column index at the specified coordinates,
// relative to the specified item
//---------------------------------------------------------------------------
function Manual_GetColumnAt(Item: TListItem; const Pt: TPoint): Integer;
var
LV: TCustomListViewAccess;
R: TRect;
I: Integer;
begin
LV := TCustomListViewAccess(Item.ListView);
// determine the dimensions of the current column value, and
// see if the coordinates are inside of the column value
// get the dimensions of the entire item
R := Item.DisplayRect(drBounds);
// loop through all of the columns looking for the value that was clicked on
for I := 0 to LV.Columns.Count-1 do
begin
R.Right := (R.Left + LV.Column[I].Width);
if PtInRect(R, Pt) then
begin
Result := I;
Exit;
end;
R.Left := R.Right;
end;
Result := -1;
end;
//---------------------------------------------------------------------------
// Manual_GetColumnRect
//
// Purpose: Calculate the dimensions of the specified column,
// relative to the specified item
//---------------------------------------------------------------------------
function Manual_GetColumnRect(Item: TListItem; ColumnIndex: Integer; var Rect: TRect): Boolean;
var
LV: TCustomListViewAccess;
I: Integer;
begin
Result := False;
LV := TCustomListViewAccess(Item.ListView);
// make sure the index is in the valid range
if (ColumnIndex >= 0) and (ColumnIndex < LV.Columns.Count) then
begin
// get the dimensions of the entire item
Rect := Item.DisplayRect(drBounds);
// loop through the columns calculating the desired offsets
for I := 0 to ColumnIndex-1 do
Rect.Left := (Rect.Left + LV.Column[i].Width);
Rect.Right := (Rect.Left + LV.Column[ColumnIndex].Width);
Result := True;
end;
end;
//---------------------------------------------------------------------------
// Manual_GetIndexesAt
//
// Purpose: Returns the Item and Column indexes at the specified coordinates
//---------------------------------------------------------------------------
function Manual_GetIndexesAt(ListView: TCustomListView; const Pt: TPoint; var Coord: TListViewCoord): Boolean;
var
Item: TListItem;
begin
Result := False;
Item := ListView.GetItemAt(Pt.x, Pt.y);
if Item <> nil then
begin
Coord.Item := Item.Index;
Coord.Column := Manual_GetColumnAt(Item, Pt);
Result := True;
end;
end;
//---------------------------------------------------------------------------
// ComCtl_GetColumnAt
//
// Purpose: Returns the column index at the specified coordinates, relative to the specified item
//---------------------------------------------------------------------------
function ComCtl_GetColumnAt(Item: TListItem; const Pt: TPoint): Integer;
var
HitTest: LV_HITTESTINFO;
begin
Result := -1;
ZeroMemory(#HitTest, SizeOf(HitTest));
HitTest.pt := Pt;
if ListView_SubItemHitTest(Item.ListView.Handle, #HitTest) > -1 then
begin
if HitTest.iItem = Item.Index then
Result := HitTest.iSubItem;
end;
end;
//---------------------------------------------------------------------------
// ComCtl_GetColumnRect
//
// Purpose: Calculate the dimensions of the specified column, relative to the specified item
//---------------------------------------------------------------------------
function ComCtl_GetColumnRect(Item: TListItem; ColumnIndex: Integer; var Rect: TRect): Boolean;
begin
Result := ListView_GetSubItemRect(Item.ListView.Handle, Item.Index, ColumnIndex, LVIR_BOUNDS, #Rect);
end;
//---------------------------------------------------------------------------
// ComCtl_GetIndexesAt
//
// Purpose: Returns the Item and Column indexes at the specified coordinates
//---------------------------------------------------------------------------
function ComCtl_GetIndexesAt(ListView: TCustomListView; const Pt: TPoint; var Coord: TListViewCoord): Boolean;
var
HitTest: LV_HITTESTINFO;
begin
Result := False;
ZeroMemory(#HitTest, SizeOf(HitTest));
HitTest.pt := Pt;
if ListView_SubItemHitTest(ListView.Handle, #HitTest) > -1 then
begin
Coord.Item := HitTest.iItem;
Coord.Column := HitTest.iSubItem;
Result := True;
end;
end;
//---------------------------------------------------------------------------
// TForm1 Constructor
//
// Purpose: Form constructor
//---------------------------------------------------------------------------
constructor TForm1.Create(Owner: TComponent);
begin
inherited Create(Owner);
// no editing yet
ColumnToEdit := -1;
OldListViewEditProc := nil;
hListViewEditWnd := 0;
ListViewEditWndProcPtr := MakeObjectInstance(ListViewEditWndProc);
if ListViewEditWndProcPtr = nil then
raise Exception.Create('Could not allocate memory for ListViewEditWndProc proxy');
if GetComCtl32Version >= DWORD(MAKELONG(70, 4)) then
begin
#GetColumnAt := #ComCtl_GetColumnAt;
#GetColumnRect := #ComCtl_GetColumnRect;
#GetIndexesAt := #ComCtl_GetIndexesAt;
end else
begin
#GetColumnAt := #Manual_GetColumnAt;
#GetColumnRect := #Manual_GetColumnRect;
#GetIndexesAt := #Manual_GetIndexesAt;
end;
end;
//---------------------------------------------------------------------------
// TForm1 Destructor
//
// Purpose: Form destructor
//---------------------------------------------------------------------------
destructor TForm1.Destroy;
begin
if ListViewEditWndProcPtr <> nil then
FreeObjectInstance(ListViewEditWndProcPtr);
inherited Destroy;
end;
//---------------------------------------------------------------------------
// ListViewEditWndProc
//
// Purpose: Custom Window Procedure for TListView's editor window
//---------------------------------------------------------------------------
procedure TForm1.ListViewEditWndProc(var Message: TMessage);
begin
if Message.Msg = WM_WINDOWPOSCHANGING then
begin
// this inline editor has a bad habit of re-positioning itself
// back on top of the Caption after every key typed in,
// so let's stop it from moving
with TWMWindowPosMsg(Message).WindowPos^ do flags := flags or SWP_NOMOVE;
Message.Result := 0;
end else
begin
// everything else
Message.Result := CallWindowProc(OldListViewEditProc, hListViewEditWnd,
Message.Msg, Message.WParam, Message.LParam);
end;
end;
//---------------------------------------------------------------------------
// ListView1DrawItem
//
// Purpose: Handler for the TListView::OnDrawItem event
//---------------------------------------------------------------------------
procedure TForm1.ListView1DrawItem(Sender: TCustomListView; Item: TListItem; Rect: TRect; State: TOwnerDrawState);
var
LV: TCustomListViewAccess;
R: TRect;
P: TPoint;
I: Integer;
S: String;
begin
LV := TCustomListViewAccess(Sender);
// erase the entire item to start fresh
R := Item.DisplayRect(drBounds);
LV.Canvas.Brush.Color := LV.Color;
LV.Canvas.FillRect(R);
// see if the mouse is currently held down, and if so update the marker as needed
if (GetKeyState(VK_LBUTTON) and $8000) <> 0 then
begin
// find the mouse cursor onscreen, convert the coordinates to client
// coordinates on the list view
GetCursorPos(P);
ColumnToEdit := GetColumnAt(Item, LV.ScreenToClient(P));
end;
// loop through all of the columns drawing each column
for I := 0 to LV.Columns.Count-1 do
begin
// determine the dimensions of the current column value
if not GetColumnRect(Item, I, R) then
Continue;
// mimic the default behavior by only drawing a value as highlighted if
// the entire item is selected, the particular column matches the marker,
// and the ListView is not already editing
if Item.Selected and (I = ColumnToEdit) and (not LV.IsEditing) then
begin
LV.Canvas.Brush.Color := clHighlight;
LV.Canvas.Font.Color := clHighlightText;
end else
begin
LV.Canvas.Brush.Color := LV.Color;
LV.Canvas.Font.Color := LV.Font.Color;
end;
LV.Canvas.FillRect(R);
// draw the column's text
if I = 0 then
S := Item.Caption
else
S := Item.SubItems[I-1];
LV.Canvas.TextRect(R, R.Left + 2, R.Top, S);
end;
end;
//---------------------------------------------------------------------------
// ListView1Edited
//
// Purpose: Handler for the TListView::OnEdited event
//---------------------------------------------------------------------------
procedure TForm1.ListView1Edited(Sender: TObject; Item: TListItem; var S: string);
begin
// ignore the Caption, let it do its default handling
if ColumnToEdit <= 0 then Exit;
// restore the previous window procedure for the inline editor
if hListViewEditWnd <> 0 then
begin
SetWindowLongPtr(hListViewEditWnd, GWL_WNDPROC, LONG_PTR(OldListViewEditProc));
hListViewEditWnd := 0;
end;
// assign the new text to the subitem being edited
Item.SubItems[ColumnToEdit-1] := S;
// prevent the default behavior from updating the Caption as well
S := Item.Caption;
end;
//---------------------------------------------------------------------------
// ListView1Editing
//
// Purpose: Handler for the TListView::OnEditing event
//---------------------------------------------------------------------------
procedure TForm1.ListView1Editing(Sender: TObject; Item: TListItem; var AllowEdit: Boolean);
var
Wnd: HWND;
R: TRect;
begin
// ignore the Caption, let it do its default handling
if ColumnToEdit <= 0 then Exit;
// get the inline editor's handle
Wnd := ListView_GetEditControl(ListView1.Handle);
if Wnd = 0 then Exit;
// determine the dimensions of the subitem being edited
if not GetColumnRect(Item, ColumnToEdit, R) then Exit;
// move the inline editor over the subitem
MoveWindow(Wnd, R.Left, R.Top - 2, R.Right-R.Left, (R.Bottom-R.Top) + 4, TRUE);
// update the inline editor's text with the subitem's text rather than the Caption
SetWindowText(Wnd, PChar(Item.SubItems[ColumnToEdit-1]));
// subclass the inline editor so we can catch its movements
hListViewEditWnd := Wnd;
OldListViewEditProc := Pointer(GetWindowLongPtr(Wnd, GWL_WNDPROC));
SetWindowLongPtr(Wnd, GWL_WNDPROC, LONG_PTR(ListViewEditWndProcPtr));
end;
//---------------------------------------------------------------------------
// ListView1MouseDown
//
// Purpose: Handler for the TListView::OnMouseDown event
//---------------------------------------------------------------------------
procedure TForm1.ListView1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var
Coord: TListViewCoord;
begin
if GetIndexesAt(ListView1, Point(X, Y), Coord) then
begin
if Coord.Column <> ColumnToEdit then
begin
// update the marker
ColumnToEdit := Coord.Column;
// cancel the editing so that the listview won't go into
// its edit mode immediately upon clicking the new item
ListView1.Items[Coord.Item].CancelEdit;
// update the display with a new highlight selection
ListView1.Invalidate;
end;
end else
ColumnToEdit := -1;
end;
end.
I took RRUZ's code and decided to make a self-contained unit of it, with a derived TListView object that supports multiple editable columns. It also allows you to move between editable items using the arrows, enter and tab.
unit EditableListView;
interface
uses
Messages,
Classes, StdCtrls, ComCtrls, System.Types,
Generics.Collections;
Const
ELV_EDIT = WM_USER + 16;
type
TEditableListView = class(TListView)
private
FEditable: TList<integer>;
FEditor: TEdit;
FItem: TListItem;
FEditColumn: integer;
procedure EditListView(var AMessage: TMessage); message ELV_EDIT;
procedure EditExit(Sender: TObject);
procedure EditKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
procedure DoEdit;
procedure CleanupEditable;
function GetEditable(const I: integer): boolean;
procedure SetEditable(const I: integer; const Value: boolean);
protected
procedure Click; override;
function DoMouseWheel(Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint): Boolean; override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
property Editable[const I: integer]: boolean read GetEditable write SetEditable;
end;
implementation
uses
Windows, SysUtils, CommCtrl, Controls;
{ TEditableListView }
constructor TEditableListView.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FEditable := TList<integer>.Create;
FEditor := TEdit.Create(self);
FEditor.Parent := self;
FEditor.OnExit := EditExit;
FEditor.OnKeyDown := EditKeyDown;
FEditor.Visible := false;
ViewStyle := vsReport; // Default to vsReport instead of vsIcon
end;
destructor TEditableListView.Destroy;
begin
FEditable.Free;
inherited Destroy;
end;
procedure TEditableListView.DoEdit;
begin
if Assigned(FItem) Then
begin
// assign the value of the TEdit to the Subitem
if FEditColumn = 0 then
FItem.Caption := FEditor.Text
else if FEditColumn > 0 then
FItem.SubItems[FEditColumn - 1] := FEditor.Text;
end;
end;
function TEditableListView.DoMouseWheel(Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint): Boolean;
begin
DoEdit;
FEditor.Visible := false;
SetFocus;
Result := inherited DoMouseWheel(Shift, WheelDelta, MousePos);
end;
procedure TEditableListView.CleanupEditable;
var
I: integer;
begin
for I := FEditable.Count - 1 downto 0 do
begin
if not Assigned(Columns.FindItemID(FEditable[I])) then
FEditable.Delete(I);
end;
end;
procedure TEditableListView.Click;
var
LPoint: TPoint;
LVHitTestInfo: TLVHitTestInfo;
begin
LPoint := ScreenToClient(Mouse.CursorPos);
FillChar(LVHitTestInfo, SizeOf(LVHitTestInfo), 0);
LVHitTestInfo.pt := LPoint;
// Check if the click was made in the column to edit
if (perform(LVM_SUBITEMHITTEST, 0, LPARAM(#LVHitTestInfo)) <> -1) Then
PostMessage(self.Handle, ELV_EDIT, LVHitTestInfo.iItem, LVHitTestInfo.iSubItem)
else
FEditor.Visible := false; //hide the TEdit
inherited Click;
end;
procedure TEditableListView.EditExit(Sender: TObject);
begin
DoEdit;
end;
procedure TEditableListView.EditKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
var
lNextRow, lNextCol: integer;
begin
if Key in [VK_RETURN, VK_TAB, VK_LEFT, VK_RIGHT, VK_UP, VK_DOWN] then
begin
DoEdit;
lNextRow := FItem.Index;
lNextCol := FEditColumn;
case Key of
VK_RETURN,
VK_DOWN:
lNextRow := lNextRow + 1;
VK_UP:
lNextRow := lNextRow - 1;
VK_TAB,
VK_RIGHT:
lNextCol := lNextCol + 1;
VK_LEFT:
lNextCol := lNextCol - 1;
end;
if not ( (Key = VK_RIGHT) and (FEditor.SelStart+FEditor.SelLength < Length(FEditor.Text)) )
and not ( (Key = VK_LEFT) and (FEditor.SelStart+FEditor.SelLength > 0) ) then
begin
Key := 0;
if (lNextRow >= 0) and (lNextRow < Items.Count)
and (lNextCol >= 0) and (lNextCol < Columns.Count) then
PostMessage(self.Handle, ELV_EDIT, lNextRow, lNextCol);
end;
end;
end;
procedure TEditableListView.EditListView(var AMessage: TMessage);
var
LRect: TRect;
begin
if Editable[AMessage.LParam] then
begin
LRect.Top := AMessage.LParam;
LRect.Left:= LVIR_BOUNDS;
Perform(LVM_GETSUBITEMRECT, AMessage.wparam, LPARAM(#LRect));
//get the current Item to edit
FItem := Items[AMessage.wparam];
FEditColumn := AMessage.LParam;
//set the text of the Edit
if FEditColumn = 0 then
FEditor.Text := FItem.Caption
else if FEditColumn > 0 then
FEditor.Text := FItem.Subitems[FEditColumn-1]
else
FEditor.Text := '';
//set the bounds of the TEdit
FEditor.BoundsRect := LRect;
//Show the TEdit
FEditor.Visible := true;
FEditor.SetFocus;
FEditor.SelectAll;
end
else
FEditor.Visible := false;
end;
function TEditableListView.GetEditable(const I: integer): boolean;
begin
if (I > 0) and (I < Columns.Count) then
Result := FEditable.IndexOf(Columns[I].ID) >= 0
else
Result := false;
CleanupEditable;
end;
procedure TEditableListView.SetEditable(const I: integer; const Value: boolean);
var
Lix: integer;
begin
if (I > 0) and (I < Columns.Count) then
begin
Lix := FEditable.IndexOf(Columns[I].ID);
if Value and (Lix < 0)then
FEditable.Add(Columns[I].ID)
else if not Value and (Lix >= 0) then
FEditable.Delete(Lix);
end;
CleanupEditable;
end;
end.
EDIT1: Added detection for mousewheel scroll to exit editing.
EDIT2: Allow for moving the cursor within the edit box with the arrow keys
From the review queue:
For those interested, I've created a TListView extension based in
RRUZ's answer
https://github.com/BakasuraRCE/TEditableListView
The code is as follows:
unit UnitEditableListView;
interface
uses
Winapi.Windows,
Winapi.Messages,
Winapi.CommCtrl,
System.Classes,
Vcl.ComCtrls,
Vcl.StdCtrls;
type
///
/// Based on: https://stackoverflow.com/a/10836109
///
TListView = class(Vcl.ComCtrls.TListView)
strict private
FListViewEditor: TEdit;
FEditorItemIndex, FEditorSubItemIndex: Integer;
FCursorPos: TPoint;
// Create native item
function CreateItem(Index: Integer; ListItem: TListItem): TLVItem;
// Free TEdit
procedure FreeEditorItemInstance;
// Invalidate cursor position
procedure ResetCursorPos;
{
TEdit Events
}
procedure ListViewEditorExit(Sender: TObject);
procedure ListViewEditorKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
procedure ListViewEditorKeyPress(Sender: TObject; var Key: Char);
{
Override Events
}
procedure Click; override;
procedure KeyDown(var Key: Word; Shift: TShiftState); override;
{
Windows Events
}
{ TODO -cenhancement : Scroll edit control with listview }
procedure WMMouseWheel(var Message: TWMMouseWheel); message WM_MOUSEWHEEL;
procedure WMHScroll(var Message: TWMHScroll); message WM_HSCROLL;
procedure WMVScroll(var Message: TWMVScroll); message WM_VSCROLL;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
///
/// Start edition on local position
///
procedure EditCaptionAt(Point: TPoint);
end;
implementation
uses
Vcl.Controls;
{ TListView }
procedure TListView.Click;
begin
inherited;
// Get current point
FCursorPos := ScreenToClient(Mouse.CursorPos);
FreeEditorItemInstance;
end;
constructor TListView.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
// Create the TEdit and assign the OnExit event
FListViewEditor := TEdit.Create(AOwner);
with FListViewEditor do
begin
Parent := Self;
OnKeyDown := ListViewEditorKeyDown;
OnKeyPress := ListViewEditorKeyPress;
OnExit := ListViewEditorExit;
Visible := False;
end;
end;
destructor TListView.Destroy;
begin
// Free TEdit
FListViewEditor.Free;
inherited;
end;
procedure TListView.EditCaptionAt(Point: TPoint);
var
Rect: TRect;
CursorPos: TPoint;
HitTestInfo: TLVHitTestInfo;
CurrentItem: TListItem;
begin
// Set position to handle
HitTestInfo.pt := Point;
// Get item select
if ListView_SubItemHitTest(Handle, #HitTestInfo) = -1 then
Exit;
with HitTestInfo do
begin
FEditorItemIndex := iItem;
FEditorSubItemIndex := iSubItem;
end;
// Nothing?
if (FEditorItemIndex < 0) or (FEditorItemIndex >= Items.Count) then
Exit;
if FEditorSubItemIndex < 0 then
Exit;
CurrentItem := Items[ItemIndex];
if not CanEdit(CurrentItem) then
Exit;
// Get bounds
ListView_GetSubItemRect(Handle, FEditorItemIndex, FEditorSubItemIndex, LVIR_LABEL, #Rect);
// set the text of the Edit
if FEditorSubItemIndex = 0 then
FListViewEditor.Text := CurrentItem.Caption
else
begin
FListViewEditor.Text := CurrentItem.SubItems[FEditorSubItemIndex - 1];
end;
// Set the bounds of the TEdit
FListViewEditor.BoundsRect := Rect;
// Show the TEdit
FListViewEditor.Visible := True;
// Set focus
FListViewEditor.SetFocus;
end;
procedure TListView.ResetCursorPos;
begin
// Free cursos pos
FCursorPos := Point(-1, -1);
end;
procedure TListView.FreeEditorItemInstance;
begin
FEditorItemIndex := -1;
FEditorSubItemIndex := -1;
FListViewEditor.Visible := False; // Hide the TEdit
end;
procedure TListView.KeyDown(var Key: Word; Shift: TShiftState);
begin
inherited KeyDown(Key, Shift);
// F2 key start edit
if (Key = VK_F2) then
EditCaptionAt(FCursorPos);
end;
///
/// Create a LVItem
///
function TListView.CreateItem(Index: Integer; ListItem: TListItem): TLVItem;
begin
with Result do
begin
mask := LVIF_PARAM or LVIF_IMAGE or LVIF_GROUPID;
iItem := index;
iSubItem := 0;
iImage := I_IMAGECALLBACK;
iGroupId := -1;
pszText := PChar(ListItem.Caption);
{$IFDEF CLR}
lParam := ListItem.GetHashCode;
{$ELSE}
lParam := Winapi.Windows.lParam(ListItem);
{$ENDIF}
end;
end;
procedure TListView.ListViewEditorExit(Sender: TObject);
begin
// I have an instance?
if FEditorItemIndex = -1 then
Exit;
// Assign the value of the TEdit to the Subitem
if FEditorSubItemIndex = 0 then
Items[FEditorItemIndex].Caption := FListViewEditor.Text
else
Items[FEditorItemIndex].SubItems[FEditorSubItemIndex - 1] := FListViewEditor.Text;
// Raise OnEdited event
Edit(CreateItem(FEditorItemIndex, Items[FEditorItemIndex]));
// Free instanse
FreeEditorItemInstance;
end;
procedure TListView.ListViewEditorKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
// ESCAPE key exit of editor
if Key = VK_ESCAPE then
FreeEditorItemInstance;
end;
procedure TListView.ListViewEditorKeyPress(Sender: TObject; var Key: Char);
begin
// Update item on press ENTER
if (Key = #$0A) or (Key = #$0D) then
FListViewEditor.OnExit(Sender);
end;
procedure TListView.WMHScroll(var Message: TWMHScroll);
begin
inherited;
// Reset cursos pos
ResetCursorPos;
// Free instanse
FreeEditorItemInstance;
end;
procedure TListView.WMMouseWheel(var Message: TWMMouseWheel);
begin
inherited;
// Reset cursos pos
ResetCursorPos;
// Free instanse
FreeEditorItemInstance;
end;
procedure TListView.WMVScroll(var Message: TWMVScroll);
begin
inherited;
// Reset cursos pos
ResetCursorPos;
// Free instanse
FreeEditorItemInstance;
end;
end.
The original poster's, Bakasura, answer had been deleted:
Anyone know how to drag the report in TppViewer? (Delphi 7) i try to use the dagdrop event and dragover event of ppviewer but failed, anyone can help?
procedure Tfrm1.ppviewer1DragOver(Sender, Source: TObject; X,
Y: Integer; State: TDragState; var Accept: Boolean);
begin
inherited;
Accept := Source IS TppViewer;
end;
procedure Tfrm1.ppviewer1DragDrop(Sender, Source: TObject; X,
Y: Integer);
begin
inherited;
if Source is TppViewer then begin
TppViewer(Source).Left := X;
TppViewer(Source).Top := Y;
end;
end;
This answer assumes that you are trying to scroll in the report, by dragging.
TReportPreviewer is the Form
ReportViewer is the ppViewer
Dragging is a Boolean
SaveX, SaveY are Integer
procedure TReportPreviewer.ReportViewerMouseDown(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
Dragging := true;
SaveX := X;
SaveY := Y;
end;
procedure TReportPreviewer.ReportViewerMouseMove(Sender: TObject;
Shift: TShiftState; X, Y: Integer);
begin
if Dragging then
begin
if ReportViewer.ScrollBox.Visible then
ReportViewer.ScrollBox.HorzScrollBar.Position := ReportViewer.ScrollBox.HorzScrollBar.Position - (X - SaveX);
if ReportViewer.ScrollBox.Visible then
ReportViewer.ScrollBox.VertScrollBar.Position := ReportViewer.ScrollBox.VertScrollBar.Position - (Y - SaveY);
SaveX := X;
SaveY := Y;
end;
end;
procedure TReportPreviewer.ReportViewerMouseUp(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
Dragging := false;
end;
I tried using ScrollBy instead of moving the scrollbar position, but it seemed to reset for some reason.
Are you trying to drag a report file into the Viewer? if so biased on the following advice:
How to Drop Images from Windows Explorer to a TImage control
Delphi - Drag & Drop with ListView
WM_DROPFILES Message
You can achieve this by using the following code:
procedure TMainForm.FormCreate(Sender: TObject);
begin
//Tell Windows that the Report Viewer accepts files
ShellAPI.DragAcceptFiles(ppViewer1.Handle,True);
Application.OnMessage := ApplicationMessage;
end;
procedure TMainForm.ApplicationMessage(var Msg: TMsg; var Handled: Boolean);
begin
if (Msg.hwnd = ppViewer1.Handle) and (Msg.message = WM_DROPFILES) then
begin
Handled := ReportFileDrop(Msg);
end;
end;
function TMainForm.ReportFileDrop(var Msg: TMsg):Boolean ;
var
numFiles : longInt;
buffer : array[0..MAX_PATH] of char;
l_file:String;
l_filemsg:TWMDROPFILES;
begin
Result := False;
//Convert the TMsg into a TWMDROPFILES record
l_filemsg.Msg := Msg.message;
l_filemsg.Drop := Msg.wParam;
l_filemsg.Unused := Msg.lParam;
l_filemsg.Result := 0;
numFiles := DragQueryFile(l_filemsg.Drop, $FFFFFFFF, nil, 0) ;
if numFiles > 1 then
begin
ShowMessage('You can drop only one file at a time!') ;
end
else
begin
try
DragQueryFile(l_filemsg.Drop, 0, #buffer, sizeof(buffer)) ;
l_file := buffer;
//Only try and load the report if the file has the correct extension
if (Length(l_file) > 0) and (ExtractFileExt(LowerCase(l_file)) = '.rtm') then
begin
//Load the Report
Result := True;
end;
except
//Handle errors
end;
end;
end;
I have a TTreeView that can have lots of nodes, when a lot of nodes are expanded the tree uses a lot of screen space.
Now suppose I want to drag a node that is near the bottom of the TreeView to the top, I can't physically see the top part of the TreeView because the node I am selecting is at the bottom. When dragging the node to the top of the TreeView I would like the TreeView to automatically scroll with me when dragging, by default this does not seem to happen.
A perfect example of this behaviour is seen in Windows Explorer. If you try to drag a file or folder, when you hover the dragged item (node) it automatically scrolls up or down depending on cursor position.
Hope that makes sense.
PS, I already know how to drag nodes, I want the TreeView to scroll with me when dragging if hovering near the top or bottom of the TreeView.
Thanks.
This is the code I use. It will work for any TWinControl descendent: list box, tree view, list view etc.
type
TAutoScrollTimer = class(TTimer)
private
FControl: TWinControl;
FScrollCount: Integer;
procedure InitialiseTimer;
procedure Timer(Sender: TObject);
public
constructor Create(Control: TWinControl);
end;
{ TAutoScrollTimer }
constructor TAutoScrollTimer.Create(Control: TWinControl);
begin
inherited Create(Control);
FControl := Control;
InitialiseTimer;
end;
procedure TAutoScrollTimer.InitialiseTimer;
begin
FScrollCount := 0;
Interval := 250;
Enabled := True;
OnTimer := Timer;
end;
procedure TAutoScrollTimer.Timer(Sender: TObject);
procedure DoScroll;
var
WindowEdgeTolerance: Integer;
Pos: TPoint;
begin
WindowEdgeTolerance := Min(25, FControl.Height div 4);
GetCursorPos(Pos);
Pos := FControl.ScreenToClient(Pos);
if not InRange(Pos.X, 0, FControl.Width) then begin
exit;
end;
if Pos.Y<WindowEdgeTolerance then begin
SendMessage(FControl.Handle, WM_VSCROLL, SB_LINEUP, 0);
end else if Pos.Y>FControl.Height-WindowEdgeTolerance then begin
SendMessage(FControl.Handle, WM_VSCROLL, SB_LINEDOWN, 0);
end else begin
InitialiseTimer;
exit;
end;
if FScrollCount<50 then begin
inc(FScrollCount);
if FScrollCount mod 5=0 then begin
//speed up the scrolling by reducing the timer interval
Interval := MulDiv(Interval, 3, 4);
end;
end;
if Win32MajorVersion<6 then begin
//in XP we need to clear up transient "fluff"; results in flickering so only do it in XP where it is needed
FControl.Invalidate;
end;
end;
begin
if Mouse.IsDragging then begin
DoScroll;
end else begin
Free;
end;
end;
Then to use it you add an OnStartDrag event handler for the control and implement it like this:
procedure TMyForm.SomeControlStartDrag(Sender: TObject; var DragObject: TDragObject);
begin
TAutoScrollTimer.Create(Sender as TWinControl);
end;
Here's an alternative based on the fact that the selected node always automatically scrolls in view.
type
TForm1 = class(TForm)
TreeView1: TTreeView;
TreeView2: TTreeView;
procedure TreeViewDragOver(Sender, Source: TObject; X, Y: Integer;
State: TDragState; var Accept: Boolean);
procedure TreeViewEndDrag(Sender, Target: TObject; X, Y: Integer);
procedure TreeViewMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
private
FDragNode: TTreeNode;
FNodeHeight: Integer;
end;
...
procedure TForm1.TreeViewMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
with TTreeView(Sender) do
begin
FDragNode := GetNodeAt(X, Y);
if FDragNode <> nil then
begin
Selected := FDragNode;
with FDragNode.DisplayRect(False) do
FNodeHeight := Bottom - Top;
BeginDrag(False, Mouse.DragThreshold);
end;
end;
end;
procedure TForm1.TreeViewDragOver(Sender, Source: TObject; X, Y: Integer;
State: TDragState; var Accept: Boolean);
var
Pt: TPoint;
DropNode: TTreeNode;
begin
Accept := Source is TTreeView;
if Accept then
with TTreeView(Source) do
begin
if Sender <> Source then
Pt := ScreenToClient(Mouse.CursorPos)
else
Pt := Point(X, Y);
if Pt.Y < FNodeHeight then
DropNode := Selected.GetPrevVisible
else if Pt.Y > (ClientHeight - FNodeHeight) then
DropNode := Selected.GetNextVisible
else
DropNode := GetNodeAt(Pt.X, Pt.Y);
if DropNode <> nil then
Selected := DropNode;
end;
end;
procedure TForm1.TreeViewEndDrag(Sender, Target: TObject; X, Y: Integer);
var
DropNode: TTreeNode;
begin
with TTreeView(Sender) do
if Target <> nil then
begin
DropNode := Selected;
DropNode := Items.Insert(DropNode, '');
DropNode.Assign(FDragNode);
Selected := DropNode;
Items.Delete(FDragNode);
end
else
Selected := FDragNode;
end;
You may want to link the OnDragOver event handler to the parent of the TreeView too, which results in scrolling ánd dropping when the mouse is outside the TreeView. If you dó want the scrolling, but not the dropping when the mouse is outside the TreeView, then check if Target = Sender in the OnEndDrag event handler.
Just to be complete, workarounds like in the other answers are not required anymore. Later versions have an option for this:
TreeOptions.AutoOptions.toAutoScroll := True