Tweet
Wie läßt sich erreichen, daß ein TTreeview-Inhalt bei Drag&Drop automatisch scrollt, wenn der obere/untere Bildrand erreicht wird. Von alleine scrollt leider gar nichts und die Objekte können dann nicht abgelegt werden
-
-
Hallo Michael,<br>
ich habe hier ein Beispiel für eine TListBox.<br>
Vielleihthift Dir das ja weiter<br>
<pre>
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ExtCtrls;
type
TForm1 = class(TForm)
ListBox1: TListBox;
Timer1: TTimer;
procedure ListBox1DragOver(Sender, Source: TObject; X, Y: Integer;
State: TDragState; var Accept: Boolean);
procedure Timer1Timer(Sender: TObject);
procedure ListBox1DragDrop(Sender, Source: TObject; X, Y: Integer);
private
{ Private-Deklarationen }
procedure ScrollListBox(L : TListBox);
public
{ Public-Deklarationen }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.ListBox1DragOver(Sender, Source: TObject; X, Y: Integer;
State: TDragState; var Accept: Boolean);
begin
Accept:=Sender = Listbox1;
If State = dsDragLeave then
Timer1.Enabled := False
else
Timer1.Enabled:=True;
end;
procedure TForm1.ScrollListBox(L: TListBox);
var
MP : TPoint;
begin
MP:=L.ScreenToClient(Mouse.CursorPos); // Mouse gibt's glaube ich ab D5
If MP.Y>L.Height-10 then
L.Perform(WM_VSCROLL, SB_LINEDOWN, 0);
If MP.Y<10 then
L.Perform(WM_VSCROLL, SB_LINEUP, 0);
end;
procedure TForm1.Timer1Timer(Sender: TObject);
begin
ScrollListBox(Listbox1);
end;
procedure TForm1.ListBox1DragDrop(Sender, Source: TObject; X, Y: Integer);
var
NewItemIndex : Integer;
begin
Timer1.Enabled:=False;
With (Source as TListbox) do
begin
NewItemIndex:=ItemAtPos(Point(X,Y),True);
If NewItemIndex>-1 then
Items.Exchange(ItemIndex,NewItemIndex);
end;
end;
end.</pre> -
Hier das Formular<br>
<pre>
<font face="Verdana" size="2" color="#000000"><font face="Verdana" size="1" color="#080000">object Form1: TForm1
Left = 343
Top = 233
Width = 324
Height = 268
Caption = 'Form1'
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OldCreateOrder = False
PixelsPerInch = 96
TextHeight = 13
object ListBox1: TListBox
Left = 60
Top = 68
Width = 121
Height = 97
DragMode = dmAutomatic
ItemHeight = 13
Items.Strings = (
'Item 1'
'Item 2'
'Item 3'
'Item 4'
'Item 5'
'Item 6'
'Item 7'
'Item 8'
'Item 9'
'Item 10'
'Item 11'
'Item 12'
'Item 13'
'Item 14')
TabOrder = 0
OnDragDrop = ListBox1DragDrop
OnDragOver = ListBox1DragOver
end
object Timer1: TTimer
Enabled = False
Interval = 100
OnTimer = Timer1Timer
Left = 12
Top = 20
end
end</font></font></pre>

Comment
Comment