拖动时热轨在虚拟 TListView 中不起作用

Question

如果我使用虚拟 TListView 并尝试拖动项目（Accept:= True 总是），"hot tracking" 系统看起来已损坏。在 win 7 中，热门项目保持在所选项目附近，而在 win 8.1 中，它保持固定在随机位置。我记录了这个行为以更好地理解我的意思：

Here is the recording from win 7

Here is the recording from win 8.1

这是重现问题的最少代码：

.dfm

object Form1: TForm1
  Left = 0
  Top = 0
  Caption = 'Form1'
  ClientHeight = 378
  ClientWidth = 398
  Color = clBtnFace
  DoubleBuffered = True
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'Tahoma'
  Font.Style = []
  OldCreateOrder = False
  Position = poScreenCenter
  OnCreate = FormCreate
  PixelsPerInch = 96
  TextHeight = 13
  object ListView1: TListView
    Left = 78
    Top = 40
    Width = 221
    Height = 286
    Columns = <
      item
        Width = 130
      end>
    DragMode = dmAutomatic
    MultiSelect = True
    OwnerData = True
    ReadOnly = True
    RowSelect = True
    TabOrder = 0
    ViewStyle = vsReport
    OnData = ListView1Data
    OnDragOver = ListView1DragOver
  end
end

.pas

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ComCtrls;

type
  TForm1 = class(TForm)
    ListView1: TListView;
    procedure ListView1Data(Sender: TObject; Item: TListItem);
    procedure FormCreate(Sender: TObject);
    procedure ListView1DragOver(Sender, Source: TObject; X, Y: Integer;
      State: TDragState; var Accept: Boolean);
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);
begin
 ListView1.Items.Count:= 10;
end;

procedure TForm1.ListView1Data(Sender: TObject; Item: TListItem);
begin
 Item.Caption:= 'Item '+IntToStr(Item.Index);
end;

procedure TForm1.ListView1DragOver(Sender, Source: TObject; X, Y: Integer;
  State: TDragState; var Accept: Boolean);
begin
 Accept:= True;
end;

end.

当然，问题是，是否可以采取任何措施来纠正这种行为？

编辑：

我尝试实现自己的跟踪系统，它似乎可以正常工作，但有一点例外：光标下最上面的项目始终处于选中状态...

function TListView.GetItemIndexAt(X, Y: Integer): Integer;
var Info: TLVHitTestInfo;
begin
 Result:= -1;
 if HandleAllocated then begin
  Info.pt:= Point(X, Y);
  Result:= ListView_HitTest(Handle, Info);
 end;
end;

procedure TForm1.ListView1DragOver(Sender, Source: TObject; X, Y: Integer;
  State: TDragState; var Accept: Boolean);
var Src, Dest, I: Integer;
begin
 Accept:= True;
 Src:= ListView1.Selected.Index;
 Dest:= ListView1.GetItemIndexAt(X, Y);
 for I:= 0 to ListView1.Items.Count-1 do
  if (I = Src) or (I = Dest) then ListView1.Items[I].Selected:= True
   else ListView1.Items[I].Selected:= False;
end;

Answer 1

我已通过重置所有项目的 LVIS_DROPHILITED 状态并将此状态设置为刚刚拖过的项目解决了这个问题：

type
  TListView = class(ComCtrls.TListView)
  protected
    procedure DragOver(Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean); override;
    procedure DoEndDrag(Target: TObject; X, Y: Integer); override;
  public
    function GetItemIndexAt(X, Y: Integer): Integer;
  end;

function TListView.GetItemIndexAt(X, Y: Integer): Integer;
var
  HitInfo: TLVHitTestInfo;
begin
  Result := -1;
  if HandleAllocated then
  begin
    HitInfo.pt := Point(X, Y);
    Result := ListView_HitTest(Handle, HitInfo);
  end;
end;

procedure TListView.DragOver(Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean);
var
  DropIndex: Integer;
begin
  inherited;
  if OwnerData then
  begin
    ListView_SetItemState(Handle, -1, 0, LVIS_DROPHILITED);
    if Accept then
    begin
      DropIndex := GetItemIndexAt(X, Y);
      if DropIndex <> -1 then
        ListView_SetItemState(Handle, DropIndex, LVIS_DROPHILITED, LVIS_DROPHILITED);
    end;
  end;
end;

procedure TListView.DoEndDrag(Target: TObject; X, Y: Integer);
begin
  if OwnerData then
    ListView_SetItemState(Handle, -1, 0, LVIS_DROPHILITED);
  inherited;
end;

拖动时热轨在虚拟 TListView 中不起作用

Hot track doesn't work in a virtual TListView while dragging

delphi

debugging

listview

delphi-2009