The code is fairly basic and made so that it can be clearly understood and applied to other types of controls.
Drag & Drop from windows Explorer is handled by an application by registering a window handle along with an instance of an IDropTarget interface.
To make to code easy to reuse, I encapsulated the IDropTarget implementation into a class named TDropTarget and expose the features the Delphi way: using event.
To allow Drag & Drop from Windows Explorer to one of your form, you have to create an instance of TDropTarget and call his Register method passing the form’s handle. Of course you have to assign the events to handler in your form. The events handle all drag and drop operation:
DropAllowed event is called once when the dragged files are entering the area of the registered window. The event handler must set the “Allowed” var argument to TRUE if dropping the file(s) is allowed at the given point.
DragOver event is called as mouse move above the registered window. The event handler must set the “Allowed” var argument to TRUE if dropping the file(s) is allowed at the given point.
Drop event is called when the user drops the files.
DragLeave event is called when the dragged files leave the registered window area.
I could have made a component of TDropTarget but I didn’t. It is a simple object deriving from Object. As it implements an interface IDroptarget, beside the methods of this interface, the object also has to handle _AddRef, _Release and QueryInterface methods which exist in all interfaces. Here we use TObject life cycle, so those methods are simply do-nothing methods.
The code required in your form include creating the object in the form’s contructor (or FormCreate event), assign the event handlers. And of course free the object instance in the destructor:
constructor TDragDropMainForm.Create(AOwner: TComponent);
begin
FDropTarget := TDropTarget.Create;
FDropTarget.OnDropAllowed := ImageDropAllowedHandler;
FDropTarget.OnDrop := ImageDropHandler;
FDropTarget.OnDragOver := ImageDragOverHandler;
inherited Create(AOwner);
end;
destructor TDragDropMainForm.Destroy;
begin
FreeandNil(FDropTarget);
inherited;
end;
Register and Revoke should be called when the window handle is created or destroyed. For that, we have to override CreateWnd and DestroyWnd.
procedure TDragDropMainForm.CreateWnd;
begin
inherited CreateWnd;
if Assigned(FDropTarget) then
FDropTarget.Register(Handle);
end;
procedure TDragDropMainForm.DestroyWnd;
begin
inherited DestroyWnd;
if Assigned(FDropTarget) then
FDropTarget.Revoke;
end;
The demo application uses a TListView in vsList view mode and a TImage. The ListView accept the dropped images from Windows Explorer while TImage accepte images dropped from TListView. It is a good exercise for you to make TImage accept image also from Windows Explorer.
The demo application doesn’t show image in real size in TListView. Rather, it creates a thumbnail which is displayed in the list view. The thumbnails are stored on disk in the same folder as the original image and are only created if it doesn’t exist yet, or if the original image has been modified. Storing the thumbnail on disk could be a problem in some application because it requires write permission. In my application (Well the application I extracted this code from), it is an advantage because the images are very large and it takes time to create the thumbnails. Keeping the thumbnails on disk improve performance.
Thumbnails are created using GDI+ (See my other blog article about it: http://francois-piette.blogspot.be/2013/05/opensource-gdi-library.html). The code is really easy:
Image := TGPImage.Create(AFileName);
Thumbnail := Image.GetThumbnailImage(ThWidth, ThHeight, nil, nil);
Quality := 50;
Params := TGPEncoderParameters.Create;
Params.Add(EncoderQuality, Quality);
Thumbnail.Save(AThumbFileName, TGPImageFormat.Jpeg, Params);
A last note about the demo application: I used custom draw of the ListView items so that it looks exactly how I require it. All list view items are represented by a class named TImageListViewItem. I have selected this representation because in the real application this demo is extracted from, there is a lot of information about each image. The class is really handy to hold the information and the processing related to it.
Here after is the complete source code. There are mainly two files: DropHanlder.pas and DragDropMain.pas. You can also download a zip file with the complete project. See my website at: http://www.overbyte.be/frame_index.html?redirTo=/blog_source_code.html
DropHandler.pas
unit DropHandler;
interface
uses
Windows, Types, Classes, SysUtils, ShellAPI, ActiveX;
type
TStringArray = array of String;
TDropAllowedEvent = procedure (Sender : TObject;
const FileNames : array of String;
const grfKeyState : Longint;
const pt : TPoint;
var Allowed : Boolean)
of object;
TDragOverEvent = procedure (Sender : TObject;
const grfKeyState : Longint;
const pt : TPoint;
var Allowed : Boolean)
of object;
TDropEvent = procedure (Sender : TObject;
const DropPoint : TPoint;
const FileNames : array of String)
of object;
TDropTarget = class(TObject, IDropTarget)
private
FRegisteredHandle : HWND;
FDropAllowed : Boolean;
FOnDropAllowed : TDropAllowedEvent;
FOnDrop : TDropEvent;
FOnDragOver : TDragOverEvent;
FOnDragLeave : TNotifyEvent;
procedure GetFileNames(const dataObj : IDataObject;
var FileNames : TStringArray);
function DragEnter(const dataObj : IDataObject;
grfKeyState : Integer;
pt : TPoint;
var dwEffect : Integer): HResult; stdcall;
function DragOver(grfKeyState : Longint;
pt : TPoint;
var dwEffect : Longint): HResult; stdcall;
function DragLeave: HResult; stdcall;
function Drop(const dataObj : IDataObject;
grfKeyState : Longint;
pt : TPoint;
var dwEffect : Longint): HResult; stdcall;
function _AddRef: Integer; stdcall;
function _Release: Integer; stdcall;
function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
public
destructor Destroy; override;
// Call Register() with a window handle so that that window starts
// accepting dropped files. Events will then be generated.
function Register(AHandle : HWnd) : HResult;
// Stop accepting files dropped on the registered window.
procedure Revoke;
// DropAllowed event is called once when the dragged files are
// entering the area of the registered window.
// The event handler must set the Allowed var argument to TRUE if
// dropping the file(s) is allowed at the given point
property OnDropAllowed : TDropAllowedEvent read FOnDropAllowed
write FOnDropAllowed;
// DragOver event is called as mouse move above the registered window
// The event handler must set the Allowed var argument to TRUE if
// dropping the file(s) is allowed at the given point
property OnDragOver : TDragOverEvent read FOnDragOver
write FOnDragOver;
// Drop event is called when the user drops the files.
property OnDrop : TDropEvent read FOnDrop
write FOnDrop;
// DragLeave event is called when the dragged files leave the
// registered window area.
property OnDragLeave : TNotifyEvent read FOnDragLeave
write FOnDragLeave;
end;
implementation
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TDropTarget.Register(AHandle: HWnd): HResult;
begin
if FRegisteredHandle = AHandle then begin
Result := S_OK;
Exit;
end;
if FRegisteredHandle <> 0 then
Revoke;
FRegisteredHandle := AHandle;
Result := ActiveX.RegisterDragDrop(FRegisteredHandle, Self);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TDropTarget.Revoke;
begin
if FRegisteredHandle <> 0 then begin
ActiveX.RevokeDragDrop(FRegisteredHandle);
FRegisteredHandle := 0;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
destructor TDropTarget.Destroy;
begin
Revoke;
inherited Destroy;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TDropTarget.GetFileNames(
const dataObj : IDataObject;
var FileNames : TStringArray);
var
I : Integer;
FormatetcIn : TFormatEtc;
Medium : TStgMedium;
DropHandle : HDROP;
begin
FileNames := nil;
FormatetcIn.cfFormat := CF_HDROP;
FormatetcIn.ptd := nil;
FormatetcIn.dwAspect := DVASPECT_CONTENT;
FormatetcIn.lindex := -1;
FormatetcIn.tymed := TYMED_HGLOBAL;
if dataObj.GetData(FormatetcIn, Medium) = S_OK then begin
DropHandle := HDROP(Medium.hGlobal);
SetLength(FileNames, DragQueryFile(DropHandle, $FFFFFFFF, nil, 0));
for I := 0 to high(FileNames) do begin
SetLength(FileNames[I], DragQueryFile(DropHandle, I, nil, 0));
DragQueryFile(DropHandle, I, @FileNames[I][1],
Length(FileNames[I]) + 1);
end;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TDropTarget.DragEnter(
const dataObj : IDataObject;
grfKeyState : Integer;
pt : TPoint;
var dwEffect : Integer): HResult;
var
FileNames: TStringArray;
begin
Result := S_OK;
try
GetFileNames(dataObj, FileNames);
if (Length(FileNames) > 0) and Assigned(FOnDropAllowed) then begin
FDropAllowed := FALSE;
FOnDropAllowed(Self, FileNames, grfKeyState, pt, FDropAllowed);
end;
if FDropAllowed then
dwEffect := DROPEFFECT_COPY
else
dwEffect := DROPEFFECT_NONE;
except
Result := E_UNEXPECTED;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TDropTarget.DragLeave: HResult;
begin
if Assigned(FOnDragLeave) then
FOnDragLeave(Self);
Result := S_OK;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TDropTarget.DragOver(
grfKeyState : Integer;
pt : TPoint;
var dwEffect : Integer): HResult;
begin
Result := S_OK;
try
if Assigned(FOnDragOver) then
FOnDragOver(Self, grfKeyState, pt, FDropAllowed);
if FDropAllowed then
dwEffect := DROPEFFECT_COPY
else
dwEffect := DROPEFFECT_NONE;
except
Result := E_UNEXPECTED;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TDropTarget.Drop(
const dataObj : IDataObject;
grfKeyState : Integer;
pt : TPoint;
var dwEffect : Integer): HResult;
var
FileNames: TStringArray;
begin
Result := S_OK;
try
GetFileNames(dataObj, FileNames);
if (Length(FileNames) > 0) and Assigned(FOnDrop) then
FOnDrop(Self, Pt, FileNames);
except
// Silently ignore any exception bacsue if required, they should
// be handled in OnDrop event handler.
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TDropTarget.QueryInterface(const IID: TGUID; out Obj): HResult;
begin
if GetInterface(IID, Obj) then
Result := 0
else
Result := E_NOINTERFACE;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TDropTarget._AddRef: Integer;
begin
// We don't use reference counting in this object
// We need _AddRef because RegisterDragDrop API call it
Result := 1;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TDropTarget._Release: Integer;
begin
// We don't use reference counting in this object
// We need _Release because RevokeDragDrop API call it
Result := 1;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
end.
DragDropMain.pas
unit DragDropMain;
interface
uses
Windows, Messages, Types, SysUtils, Variants, Classes, Graphics,
StdCtrls, ExtCtrls, Controls, ComCtrls, CommCtrl, Forms, Dialogs,
Jpeg, ImgList,
GdiPlus,
DropHandler;
const
AtEndOfPipe = -1;
AtTopOfPipe = -2;
THUMBNAIL_SIZE = 64;
THUMBNAIL_MARGIN = 8;
// List of accepted image file extensions
Exts : array [0..3] of String = ('.jpg', '.png', '.bmp', '.tif');
type
TImageListViewItem = class
public
FileName : String;
Bitmap : TBitmap;
Data : TObject;
ThumbnailFileName : String;
constructor Create(const AFileName : String;
const AThumbnailFileName : String;
const AItem : TListItem;
const AWidth : Integer;
const AHeight : Integer);
destructor Destroy; override;
end;
TDragDropMainForm = class(TForm)
ListView1: TListView;
Splitter1: TSplitter;
Image1: TImage;
procedure ListView1CustomDrawItem(Sender : TCustomListView;
Item : TListItem;
State : TCustomDrawState;
var DefaultDraw : Boolean);
procedure ListView1Deletion(Sender : TObject;
Item : TListItem);
procedure ListView1MouseDown(Sender : TObject;
Button : TMouseButton;
Shift : TShiftState;
X, Y : Integer);
procedure ListView1MouseMove(Sender: TObject;
Shift : TShiftState;
X, Y : Integer);
procedure ListView1MouseUp(Sender : TObject;
Button : TMouseButton;
Shift : TShiftState;
X, Y : Integer);
private
FDropTarget : TDropTarget;
FMouseDownPt : TPoint;
FMouseMovePt : TPoint;
FMouseDownFlag : Boolean;
FDraggingImage : Boolean;
procedure ImageDragOverHandler(Sender : TObject;
const grfKeyState : Longint;
const pt : TPoint;
var Allowed : Boolean);
procedure ImageDropAllowedHandler(Sender : TObject;
const FileNames : array of string;
const GrfKeyState : Integer;
const Pt : TPoint;
var Allowed : Boolean);
procedure ImageDropHandler(Sender : TObject;
const DropPoint : TPoint;
const FileNames : array of string);
function DropImage(const AFileName : String;
XScreen : Integer;
YScreen : Integer): Boolean;
procedure CreateThumbnail(const AFileName : String;
var AThumbFileName : String);
function KnownExtension(const FileName : String): Boolean; overload;
function KnownExtension(const FileNames: array of string): Boolean; overload;
protected
procedure CreateWnd; override;
procedure DestroyWnd; override;
public
constructor Create(AOwner : TComponent); override;
destructor Destroy; override;
procedure AddImage(const FileName : String;
BeforeIndex : Integer);
procedure MoveImage(IFrom, ITo: Integer);
procedure RemoveImage(Index: Integer); overload;
function FindImage(const FileName: String): Integer;
function AppendImage(const FileName: String): Integer;
end;
function ReplaceThumb(const FileName : String) : String;
function ListViewMouseToItem(
Pt : TPoint;
LV : TListView;
var ColIndex : Integer): TListItem;
var
DragDropMainForm: TDragDropMainForm;
implementation
{$R *.dfm}
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ TDragDropMainForm }
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
constructor TDragDropMainForm.Create(AOwner: TComponent);
begin
FDropTarget := TDropTarget.Create;
FDropTarget.OnDropAllowed := ImageDropAllowedHandler;
FDropTarget.OnDrop := ImageDropHandler;
FDropTarget.OnDragOver := ImageDragOverHandler;
inherited Create(AOwner);
// To have TListView work correctly in vsList view mode, we must have
// at least one group, one column and a SmallImages image list.
ListView1.Groups.Clear;
ListView1.Groups.Add;
ListView1.Columns.Clear;
ListView1.Columns.Add;
// Height of displayed image is set by height of SmallImages
ListView1.SmallImages := TImageList.Create(Self);
ListView1.SmallImages.Height := THUMBNAIL_SIZE + 2 * THUMBNAIL_MARGIN;
// Width of displayed image is set by ListView_SetColumnWidth macro with
// column index set to zero.
ListView_SetColumnWidth(ListView1.Handle, 0, THUMBNAIL_SIZE + 2 * THUMBNAIL_MARGIN);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TDragDropMainForm.CreateWnd;
begin
inherited CreateWnd;
if Assigned(FDropTarget) then
FDropTarget.Register(Handle);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
destructor TDragDropMainForm.Destroy;
begin
FreeandNil(FDropTarget);
inherited;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TDragDropMainForm.DestroyWnd;
begin
inherited DestroyWnd;
if Assigned(FDropTarget) then
FDropTarget.Revoke;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TDragDropMainForm.ImageDragOverHandler(
Sender : TObject;
const grfKeyState : Longint;
const pt : TPoint;
var Allowed : Boolean);
begin
Allowed := TRUE;
if not PtInRect(ListView1.BoundsRect, ListView1.ScreenToClient(Pt)) then begin
Allowed := FALSE;
Exit;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TDragDropMainForm.ImageDropAllowedHandler(
Sender : TObject;
const FileNames : array of string;
const GrfKeyState : Integer;
const Pt : TPoint;
var Allowed : Boolean);
begin
Allowed := KnownExtension(FileNames);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TDragDropMainForm.ImageDropHandler(
Sender : TObject;
const DropPoint : TPoint;
const FileNames : array of string);
var
I : Integer;
begin
for I := 0 to High(FileNames) do
DropImage(ReplaceThumb(FileNames[I]), DropPoint.X, DropPoint.Y);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TDragDropMainForm.DropImage(
const AFileName : String;
XScreen : Integer;
YScreen : Integer) : Boolean;
var
Pt : TPoint;
Item : TListItem;
ColIndex : Integer;
begin
Result := FALSE;
// First check if the extension is allowed
if not KnownExtension(AFileName) then begin
ShowMessage('Unacceptable file type (' +
ExtractFileExt(AFileName) + ')');
Exit;
end;
// Check if we already got the image
if FindImage(AFileName) >= 0 then begin
ShowMessage(AFileName + #10 + 'Already in the ListView, ignoring');
Exit;
end;
// Check if the drop point is inside the ListView
Pt := ListView1.ScreenToClient(Point(XScreen, YScreen));
if not PtInRect(ListView1.BoundsRect, Pt) then
Exit;
// Check if dropped on an existing item
Item := ListViewMouseToItem(Pt, ListView1, ColIndex);
if not Assigned(Item) then
AppendImage(AFileName) // Not on an item, add at the end
else
AddImage(AFileName, Item.Index); // Insert before the item
Result := TRUE;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TDragDropMainForm.ListView1CustomDrawItem(
Sender : TCustomListView;
Item : TListItem;
State : TCustomDrawState;
var DefaultDraw : Boolean);
var
Bitmap : TBitMap;
Rc1 : TRect;
Rc2 : TRect;
Rc3 : TRect;
ACanvas : TCanvas;
YOff : Integer;
XOff : Integer;
begin
ACanvas := Sender.Canvas;
Rc1 := Item.DisplayRect(drBounds);
if Assigned(Item.Data) then begin
Bitmap := TImageListViewItem(Item.Data).Bitmap;
// Center the bitmap
YOff := ((THUMBNAIL_SIZE - BitMap.Height) div 2) + THUMBNAIL_MARGIN;
XOff := ((THUMBNAIL_SIZE - Bitmap.Width) div 2) + THUMBNAIL_MARGIN;
ACanvas.Draw(Rc1.Left + 2 + XOff, Rc1.Top + 2 + YOff, Bitmap);
// Draw a double FrameRect around the image with a color depending
// on the status of the image
Rc2.Left := Rc1.Left + XOff;
Rc2.Top := Rc1.Top + YOff;
Rc2.Right := Rc1.Left + Bitmap.Width + 4 + XOff;
Rc2.Bottom := Rc1.Top + Bitmap.Height + 4 + YOff;
Rc3.Left := Rc1.Left + 1 + XOff;
Rc3.Top := Rc1.Top + 1 + YOff;
Rc3.Right := Rc1.Left + Bitmap.Width + 3 + XOff;
Rc3.Bottom := Rc1.Top + Bitmap.Height + 3 + YOff;
if cdsSelected in State then
ACanvas.Brush.Color := clBlue
else if cdsHot in State then
ACanvas.Brush.Color := clRed
else
ACanvas.Brush.Color := ListView1.Color;
ACanvas.FrameRect(Rc2);
ACanvas.FrameRect(Rc3);
DefaultDraw := FALSE;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TDragDropMainForm.ListView1Deletion(
Sender : TObject;
Item : TListItem);
begin
if Assigned(Item.Data) then
TObject(Item.Data).Free;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TDragDropMainForm.ListView1MouseDown(
Sender : TObject;
Button : TMouseButton;
Shift : TShiftState;
X, Y : Integer);
begin
if ssLeft in Shift then begin
FMouseDownPt := Point(X, Y);
FMouseDownFlag := TRUE;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TDragDropMainForm.ListView1MouseMove(
Sender : TObject;
Shift : TShiftState;
X, Y : Integer);
var
Item : TListItem;
ColIndex : Integer;
begin
FMouseMovePt := Point(X, Y);
if not FMouseDownFlag then
Exit;
if not FDraggingImage then begin
Item := ListViewMouseToItem(FMouseDownPt, ListView1, ColIndex);
if Assigned(Item) then begin
FDraggingImage := TRUE;
Screen.Cursor := crDrag;
SetCaptureControl(ListView1);
end;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TDragDropMainForm.ListView1MouseUp(
Sender : TObject;
Button : TMouseButton;
Shift : TShiftState;
X, Y : Integer);
var
Pt : TPoint;
ItemFrom : TListItem;
ItemTo : TListItem;
ColIndex : Integer;
LV : TListView;
IFrom : Integer;
ITo : Integer;
FileName : String;
begin
FMouseDownFlag := FALSE;
if FDraggingImage then begin
FDraggingImage := FALSE;
Screen.Cursor := crDefault;
SetCaptureControl(nil);
LV := Sender as TListView;
ItemFrom := ListViewMouseToItem(FMouseDownPt, LV, ColIndex);
ItemTo := ListViewMouseToItem(Point(X, Y), LV, ColIndex);
IFrom := ItemFrom.Index;
FileName := TImageListViewItem(ItemFrom.Data).FileName;
if not FileExists(FileName) then begin
if Application.MessageBox(
PChar('File "' + FileName + '" doesn''t exist anymore' +
#10 + 'Remove from ListView ?'), 'WARNING',
MB_YESNO + MB_DEFBUTTON2) = IDYES then begin
RemoveImage(IFrom);
Exit;
end;
end;
if Assigned(ItemTo) then begin
// Drop inside of the pipe, move items around
if ItemTo <> ItemFrom then begin
ITo := ItemTo.Index;
MoveImage(IFrom, ITo);
end;
end
else begin
if PtInRect(LV.BoundsRect, Point(X, Y)) then begin
// Drop on the listview but not on an item, just move at the end
ITo := LV.Items.Count - 1;
MoveImage(IFrom, ITo);
end
else begin
// Drop outside of the ListView
// Check if within Image1
Pt := ListView1.ClientToScreen(Point(X, Y));
Pt := Image1.ScreenToClient(Pt);
if (Pt.X >= 0) and (Pt.X < Image1.Width) and
(Pt.Y >= 0) and (Pt.Y < Image1.Height) then begin
Image1.Picture.LoadFromFile(TImageListViewItem(ItemFrom.Data).FileName);
end;
end;
end;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TDragDropMainForm.AddImage(
const FileName : String;
BeforeIndex : Integer); // Index of the item where to insert (before)
var
IFrom : Integer;
begin
IFrom := AppendImage(FileName);
if IFrom < 0 then
Exit; // Not found or already exist, not added
if BeforeIndex = AtTopOfPipe then
MoveImage(IFrom, 0)
else if (BeforeIndex >= 0) and (BeforeIndex < ListView1.Items.Count) then
MoveImage(IFrom, BeforeIndex);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
// Search if a give file already exists in list.
// Return -1 if not found
// Return item index if already in the list
function TDragDropMainForm.FindImage(const FileName: String): Integer;
begin
for Result := 0 to ListView1.Items.Count - 1 do begin
if SameText(FileName,
TImageListViewItem(ListView1.Items[Result].Data).FileName) then
Exit;
end;
Result := -1;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TDragDropMainForm.MoveImage(
IFrom : Integer;
ITo : Integer);
var
Data : Pointer;
Capt : String;
I : Integer;
begin
if IFrom < ITo then begin
Data := ListView1.Items[IFrom].Data;
Capt := ListView1.Items[IFrom].Caption;
for I := IFrom to ITo - 1 do begin
ListView1.Items[I].Data := ListView1.Items[I + 1].Data;
ListView1.Items[I].Caption := ListView1.Items[I + 1].Caption;
TImageListViewItem(ListView1.Items[I].Data).Data := ListView1.Items[I];
end;
ListView1.Items[ITo].Data := Data;
ListView1.Items[ITo].Caption := Capt;
TImageListViewItem(ListView1.Items[ITo].Data).Data := ListView1.Items[ITo];
end
else begin
Data := ListView1.Items[IFrom].Data;
Capt := ListView1.Items[IFrom].Caption;
for I := IFrom downto ITo + 1 do begin
ListView1.Items[I].Data := ListView1.Items[I - 1].Data;
ListView1.Items[I].Caption := ListView1.Items[I - 1].Caption;
TImageListViewItem(ListView1.Items[I].Data).Data := ListView1.Items[I];
end;
ListView1.Items[ITo].Data := Data;
ListView1.Items[ITo].Caption := Caption;
TImageListViewItem(ListView1.Items[ITo].Data).Data := ListView1.Items[ITo];
end;
Windows.InvalidateRect(ListView1.Handle, nil, FALSE);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TDragDropMainForm.KnownExtension(
const FileName : String) : Boolean;
var
Ext : String;
I : Integer;
begin
Result := FALSE;
Ext := ExtractFileExt(FileName);
for I := Low(Exts) to High(Exts) do begin
if SameText(Ext, Exts[I]) then begin
Result := TRUE;
Exit;
end;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TDragDropMainForm.KnownExtension(
const FileNames : array of string) : Boolean;
var
I : Integer;
begin
Result := FALSE;
for I := Low(FileNames) to High(FileNames) do begin
if KnownExtension(FileNames[I]) then begin
Result := TRUE;
Exit;
end;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
// Given a filename which could be a thumbnail filename, return either the
// filename unchanged or the image which is represented by thumbnail
function ReplaceThumb(const FileName : String) : String;
const
ThSuffix = '.thumb.jpg';
var
S : String;
I : Integer;
begin
if not SameText(Copy(FileName, Length(FileName) - Length(ThSuffix) + 1, 200),
ThSuffix) then begin
Result := FileName;
Exit;
end;
S := Copy(FileName, 1, Length(FileName) - Length(ThSuffix));
for I := Low(Exts) to High(Exts) do begin
Result := S + Exts[I];
if FileExists(Result) then
Exit;
end;
Result := FileName;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
// ColIndex returns the column index, not the SubItem index.
function ListViewMouseToItem(
Pt : TPoint;
LV : TListView;
var ColIndex : Integer): TListItem;
var
Info : TLVHitTestInfo;
begin
// Pt := LV.ScreenToClient(Mouse.Cursorpos);
Result := LV.GetItemAt(Pt.X, Pt.Y);
if Assigned(Result) then
ColIndex := 0
else begin
FillChar(Info, SizeOf(Info), 0);
Info.Pt := Pt;
if LV.Perform(LVM_SUBITEMHITTEST, 0, LParam(@Info)) <> -1 then begin
Result := LV.Items[Info.iItem];
ColIndex := Info.iSubItem;
end;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TDragDropMainForm.AppendImage(
const FileName : String) : Integer;
var
Item : TListItem;
ThumbnailFileName : String;
begin
Result := -1;
if not FileExists(FileName) then
Exit;
if FindImage(FileName) >= 0 then
Exit; // Already exist, do not add
ThumbnailFileName := '';
CreateThumbnail(FileName, ThumbnailFileName);
Item := ListView1.Items.Add;
// Item.Caption is used as the hint
Item.Caption := FileName;
Item.Data := TImageListViewItem.Create(FileName,
ThumbnailFileName,
Item,
THUMBNAIL_SIZE,
THUMBNAIL_SIZE);
Result := Item.Index;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TDragDropMainForm.RemoveImage(Index : Integer);
var
I : Integer;
begin
ListView1.Items.Delete(Index);
for I := Index to ListView1.Items.Count - 1 do
TImageListViewItem(ListView1.Items[I].Data).Data := ListView1.Items[I];
Windows.InvalidateRect(ListView1.Handle, nil, FALSE);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TDragDropMainForm.CreateThumbnail(
const AFileName : String;
var AThumbFileName : String);
var
ThWidth : Integer;
ThHeight : Integer;
FTFile : TDateTime;
FTThumb : TDateTime;
Image : IGPImage;
Thumbnail : IGPImage;
Params : IGPEncoderParameters;
Quality : Int32;
begin
AThumbFileName := ChangeFileExt(AFileName, '.thumb.jpg');
if FileExists(AThumbFileName) then begin
// Thumbnail file must be dated AFTER original file so that it
// is recreated when the original file is changed.
FileAge(AFileName, FTFile);
FileAge(AThumbFileName, FTThumb);
if FTThumb >= FTFile then
Exit;
end;
Image := TGPImage.Create(AFileName);
// Thumbnail preserve original width/height ratio
if Image.Width > Image.Height then begin
ThWidth := THUMBNAIL_SIZE;
ThHeight := THUMBNAIL_SIZE * Image.Height div Image.Width;
end
else if Image.Width < Image.Height then begin
ThHeight := THUMBNAIL_SIZE;
ThWidth := THUMBNAIL_SIZE * Image.Width div Image.Height;
end
else begin
ThWidth := THUMBNAIL_SIZE;
ThHeight := THUMBNAIL_SIZE;
end;
Thumbnail := Image.GetThumbnailImage(ThWidth, ThHeight, nil, nil);
Quality := 50;
Params := TGPEncoderParameters.Create;
Params.Add(EncoderQuality, Quality);
Thumbnail.Save(AThumbFileName, TGPImageFormat.Jpeg, Params);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ TImagePipeItem }
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
constructor TImageListViewItem.Create(
const AFileName : String;
const AThumbnailFileName : String;
const AItem : TListItem;
const AWidth : Integer;
const AHeight : Integer);
var
JpegImg : TJPEGImage;
Ext : String;
begin
inherited Create;
Data := AItem;
FileName := AFileName;
ThumbnailFileName := AThumbnailFileName;
Bitmap := TBitMap.Create;
if (AThumbnailFileName <> '') and (FileExists(AThumbnailFileName)) then begin
Ext := ExtractFileExt(AThumbnailFileName);
if SameText(Ext, '.jpg') then begin
JpegImg := TJPEGImage.Create;
try
JpegImg.LoadFromFile(AThumbnailFileName);
BitMap.Width := JpegImg.Width;
BitMap.Height := JpegImg.Height;
BitMap.Canvas.Draw(0, 0, JpegImg);
finally
JpegImg.Destroy;
end;
end
else if SameText(Ext, '.bmp') then
Bitmap.LoadFromFile(AThumbnailFileName)
end
else begin
Bitmap.Width := AWidth - 4;
Bitmap.Height := AHeight - 4;
Bitmap.PixelFormat := pf24bit;
Bitmap.Canvas.MoveTo(0, 0);
BitMap.Canvas.LineTo(Bitmap.Width, Bitmap.Height);
Bitmap.Canvas.MoveTo(Bitmap.Width, 0);
BitMap.Canvas.LineTo(0, Bitmap.Height);
BitMap.Canvas.LineTo(0, 0);
BitMap.Canvas.LineTo(Bitmap.Width - 1, 0);
BitMap.Canvas.LineTo(Bitmap.Width - 1, Bitmap.Height - 1);
BitMap.Canvas.LineTo(0, Bitmap.Height - 1);
Bitmap.Canvas.TextOut(4, 4, AFileName);
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
destructor TImageListViewItem.Destroy;
begin
FreeAndNil(Bitmap);
inherited Destroy;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
end.
Download source code from: http://www.overbyte.be/frame_index.html?redirTo=/blog_source_code.html
Follow me on Twitter
Follow me on LinkedIn
Follow me on Google+
Visit my website: http://www.overbyte.be
3 comments:
You are calling Register and Revoke in the wrong place. Your code will not be resilient to window re-creation. You'll need to make the calls from CreateWnd and DestroyWnd.
You are right David. I edited the article with updated code. Thanks.
directories can be dragged, too. I use DirectoryExists (or do you have a better idea?) to determine whether a filename is a directory or a file. You might want to consider to do this check in TDropTarget.GetFileNames and append a trailing path delimiter to directories to distinguish directories from files. Just my 2ct
Post a Comment