想实现的效果
比如:Windows桌面,我拖动一个图标是图标+图标右下角有个+号,如果按下alt,+号会变成一个向右上的箭头
我就想在程序中实现这个效果。我是用派生TDragTextObject=class(TDragControlObject)实现Drag&&Drop的
Shift键按下的消息已经截获了
但是Onkeydown消息中我调用GetDragImages改变了DragImages,但是图标并没有变化
调试过程中,可以确定,DragImages是执行了
我查了VCL源码
分析了下,实现显示Drag图像部分是由DragTo负责的
if DragObject <> nil then
with TDragDockObject(DragObject) do
if not CompareMem(@FDockRect, @FEraseDockRect, SizeOf(TRect)) then
begin
if DoErase then EraseDragDockImage;
DrawDragDockImage;
FEraseDockRect := FDockRect;
end;
这段应该是关键了
DrawDragDockImage一直往其父类实现找可以找到的实现代码是
procedure TControl.DefaultDockImage(DragDockObject: TDragDockObject;
Erase: Boolean);
var
DesktopWindow: HWND;
DC: HDC;
OldBrush: HBrush;
DrawRect: TRect;
PenSize: Integer;
begin
with DragDockObject do
begin
PenSize := FrameWidth;
if Erase then DrawRect := FEraseDockRect
else DrawRect := FDockRect;
end;
DesktopWindow := GetDesktopWindow;
DC := GetDCEx(DesktopWindow, 0, DCX_CACHE or DCX_LOCKWINDOWUPDATE);
try
OldBrush := SelectObject(DC, DragDockObject.Brush.Handle);
with DrawRect do
begin
PatBlt(DC, Left + PenSize, Top, Right - Left - PenSize, PenSize, PATINVERT);
PatBlt(DC, Right - PenSize, Top + PenSize, PenSize, Bottom - Top - PenSize, PATINVERT);
PatBlt(DC, Left, Bottom - PenSize, Right - Left - PenSize, PenSize, PATINVERT);
PatBlt(DC, Left, Top, PenSize, Bottom - Top - PenSize, PATINVERT);
end;
SelectObject(DC, OldBrush);
finally
ReleaseDC(DesktopWindow, DC);
end;
end;
明显其中的DragDockObject.Brush是关键了,如果可以刷新Brush,那么完全可以实现了
但是怎么让TDragControlObject,在Draging状态下自己刷新Brush,我就不知道了。
比如:Windows桌面,我拖动一个图标是图标+图标右下角有个+号,如果按下alt,+号会变成一个向右上的箭头
我就想在程序中实现这个效果。我是用派生TDragTextObject=class(TDragControlObject)实现Drag&&Drop的
Shift键按下的消息已经截获了
但是Onkeydown消息中我调用GetDragImages改变了DragImages,但是图标并没有变化
调试过程中,可以确定,DragImages是执行了
我查了VCL源码
分析了下,实现显示Drag图像部分是由DragTo负责的
if DragObject <> nil then
with TDragDockObject(DragObject) do
if not CompareMem(@FDockRect, @FEraseDockRect, SizeOf(TRect)) then
begin
if DoErase then EraseDragDockImage;
DrawDragDockImage;
FEraseDockRect := FDockRect;
end;
这段应该是关键了
DrawDragDockImage一直往其父类实现找可以找到的实现代码是
procedure TControl.DefaultDockImage(DragDockObject: TDragDockObject;
Erase: Boolean);
var
DesktopWindow: HWND;
DC: HDC;
OldBrush: HBrush;
DrawRect: TRect;
PenSize: Integer;
begin
with DragDockObject do
begin
PenSize := FrameWidth;
if Erase then DrawRect := FEraseDockRect
else DrawRect := FDockRect;
end;
DesktopWindow := GetDesktopWindow;
DC := GetDCEx(DesktopWindow, 0, DCX_CACHE or DCX_LOCKWINDOWUPDATE);
try
OldBrush := SelectObject(DC, DragDockObject.Brush.Handle);
with DrawRect do
begin
PatBlt(DC, Left + PenSize, Top, Right - Left - PenSize, PenSize, PATINVERT);
PatBlt(DC, Right - PenSize, Top + PenSize, PenSize, Bottom - Top - PenSize, PATINVERT);
PatBlt(DC, Left, Bottom - PenSize, Right - Left - PenSize, PenSize, PATINVERT);
PatBlt(DC, Left, Top, PenSize, Bottom - Top - PenSize, PATINVERT);
end;
SelectObject(DC, OldBrush);
finally
ReleaseDC(DesktopWindow, DC);
end;
end;
明显其中的DragDockObject.Brush是关键了,如果可以刷新Brush,那么完全可以实现了
但是怎么让TDragControlObject,在Draging状态下自己刷新Brush,我就不知道了。
我的这是我的
TDragTextObject=class(TDragControlObject)function TDragTextObject.GetDragImages: TDragImageList;
var
Bmp: Tbitmap;
index: Integer;
DC: HDC;
Rect:TRect;
DesktopWindow: HWND;
begin
Result:=inherited GetDragImages;
Result.Clear;
Bmp:=Tbitmap.Create;
try
with Bmp do
begin
Width:=Canvas.TextWidth(FText);//FText是在Drag中显示的文字
Height:=Canvas.TextHeight(FText);
Canvas.TextOut(0, 0, FText);
end;
Result.Width:=Bmp.Width;
Result.Height:=Bmp.Height;
index:=Result.Add(Bmp, nil);
Result.SetDragImage(index, Result.Width div 2, Result.Height div 2);
finally
Bmp.Free;
end;
end;
这是我代码,我也碰到了你说的总是返回nil的问题,想不通,但是这个代码确实有效,可以在Drag的时候显示FText的文字,特别是 Result:=inherited GetDragImages;
明显返回的就不是nil,不然Result.Clear;就应该出错了
用Delphi调试查看,Result := ([csInheritable]);
所以我也傻掉了
procedure TForm1.ListView1StartDrag(Sender: TObject;
var DragObject: TDragObject);
begin
if FDragTextObject=nil then//FDragTextObject是TForm1的私有变量类型TDragTextObject
FDragTextObject:=TDragTextObject.Create(ListView1);
DragObject:=FDragTextObject;
if FDragTextObject.iFlag = 0 then//iFlag记录是否shift键按下
begin
FDragTextObject.Text:='记录 被移动';
end
else
begin
FDragTextObject.Text:='记录 被复制';
end;
FDragTextObject.GetDragImages;
end;
var DragObject: TDragObject);
var
strText : string;
bmp : TBitmap;
begin
strText := '记录 被移动';
DragObject := TDragControlObjectEx.Create(ListView1);
bmp := TBitmap.Create;
with TDragTextObject(DragObject) do
try
with bmp, Canvas do
begin
Width := TextWidth(strText);
Height := TextHeight(strText);
Brush.Color := clWhite;
TextOut(0, 0, strText);
end;
with GetDragImages do
begin
Width := bmp.Width;
Height := bmp.Height;
SetDragImage(AddMasked(bmp, clWhite), Width shr 1, Height shr 1);
end;
finally
bmp.Free
end;
end;