文件拖放控件

unit DragFileAcceptor;

interface

uses
SysUtils, Classes, ShellAPI,Messages,Windows,Forms,Controls;

type
TFileDropEvent=procedure(Sender:TObject;FileNameList:TStrings) of object;
TAcceptFileEvent=procedure(Sender:TObject;FileName:string;var Accept:Boolean) of object;

TDragFileAcceptor = class(TComponent)
private
    FAcceptDirectory:Boolean;
    FEnabled:Boolean;
    FFilter:string;
    FFiltered:Boolean;
    OldWndProc, NewWndProc: Pointer;
    FOnFileDrop:TFileDropEvent;
    FOnAcceptFile:TAcceptFileEvent;
    procedure HookParent;
    procedure UnhookParent;
    procedure HookWndProc(var Msg: TMessage);
    procedure SetEnabled(const Value: Boolean);
    function GetDragFileCount(hDrop:THandle):Integer;
    function GetDragFileName(hDrop:THandle;iFile:Integer):string;
    procedure DoDragQueryFile(hDrop:THandle);
    procedure AcceptDragFile;
    procedure DeAcceptDragFile;
    function CanFileAccepted(FileName:string):Boolean;
    function FileMatchFilter(FileName:string):Boolean;
    procedure SetFilter(const Value: string);
protected
public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy;override;
published
    property Enabled:Boolean read FEnabled write SetEnabled default True;
    property Filter:string read FFilter write SetFilter;
    property OnFileDrop: TFileDropEvent read FOnFileDrop write FOnFileDrop;
    property AcceptDirectory: Boolean read FAcceptDirectory write FAcceptDirectory default True;
    property OnAcceptFile:TAcceptFileEvent read FOnAcceptFile write FOnAcceptFile;
    property Filtered:Boolean read FFiltered write FFiltered default False;
end;

procedure Register;

implementation

procedure Register;
begin
RegisterComponents('Custom', [TDragFileAcceptor]);
end;

function SinglizeStrings(StrList:TStrings;Delimiter,Terminate:string):string;
var
i:Integer;
begin
Result:='';
for i:=0 to StrList.Count-1 do
begin
    Result:=Result+StrList[i];
    if i<StrList.Count-1 then
    Result:=Result+Delimiter;
end;
if Result<>'' then
    Result:=Result+Terminate;
end;

function SingleFilterValid(Filter:string):Boolean;
begin
Result:=AnsiPos('*.',Filter)>0;
end;

function FilterListValid(Filter:TStrings):Boolean;
var
i:Integer;
begin
Result:=True;
for i:=0 to Filter.Count-1 do
    if not SingleFilterValid(Filter[i]) then
    begin
      Result:=False;
      Break;
    end;
end;

procedure DeleteStringListRedundancy(lst:TStrings);
var
i:Integer;
temp:TStrings;
begin
if lst.Count=0 then Exit;
temp:=TStringList.Create;
try
    for i:=0 to lst.Count-1 do
    if temp.IndexOf(lst[i])=-1 then
      temp.Add(lst[i]);
    lst.Assign(temp);
finally
    temp.Free;
end;
end;

function ProcessFilter(var strFilter:string):Boolean;
var
lstFilter:TStrings;
begin
Result:=True;
lstFilter:=TStringList.Create;
try
    ExtractStrings([';'],[' '],PAnsiChar(strFilter),lstFilter);
    DeleteStringListRedundancy(lstFilter);
    Result:=FilterListValid(lstFilter);
    if Result then
    begin
      if lstFilter.IndexOf('*.*')<>-1 then strFilter:='*.*'
      else strFilter:=SinglizeStrings(lstFilter,';','');
    end;
finally
    lstFilter.Free;
end;
end;

function OwnerHasInstance(Component:TComponent):Boolean;
var
i:Integer;
begin
Result:=False;
with Component do
for i:=0 to ComponentCount-1 do
begin
    if Components[i] is TDragFileAcceptor then
    Result:=True;
    Break;
end;
end;

{ TDragFileAcceptor }

procedure TDragFileAcceptor.AcceptDragFile;
begin
HookParent;
DragAcceptFiles((Owner as TWinControl).Handle,True);
end;

function TDragFileAcceptor.CanFileAccepted(FileName: string): Boolean;
begin
Result:=(FAcceptDirectory or not DirectoryExists(FileName)) and FileMatchFilter(FileName);
if Result and Assigned(FOnAcceptFile) then
    FOnAcceptFile(Self,FileName,Result);
end;

constructor TDragFileAcceptor.Create(AOwner: TComponent);
begin
if not (AOwner is TWinControl) then
begin
    raise Exception.Create('TDragFileAcceptor can only be placed on TWinControl!');
end;
if OwnerHasInstance(AOwner) then
begin
    raise Exception.Create('Only one DragFileAcceptor can be placed!');
end;
inherited;
FFilter:='*.*';
FEnabled:=True;
FFiltered:=False;
if not (csDesigning in ComponentState) then
    AcceptDragFile;
end;

procedure TDragFileAcceptor.DeAcceptDragFile;
begin
UnhookParent;
DragAcceptFiles((Owner as TWinControl).Handle,False);
end;

destructor TDragFileAcceptor.Destroy;
begin
inherited;
end;

procedure TDragFileAcceptor.DoDragQueryFile(hDrop: THandle);
var
FileList:TStrings;
iFile:Integer;
FileName:string;
begin
FileList:=TStringList.Create;
try
    for iFile:=0 to GetDragFileCount(hDrop)-1 do
    begin
      FileName:=GetDragFileName(hDrop,iFile);
      if CanFileAccepted(FileName) then
        FileList.Add(FileName);
    end;
    if Assigned(FOnFileDrop) then
      FOnFileDrop(Self,FileList);
finally
    FileList.Free;
end;
end;

function TDragFileAcceptor.FileMatchFilter(FileName: string): Boolean;
var
FilterList:TStrings;
begin
Result:=True;
if not FFiltered or (AnsiSameText(FFilter,'*.*')) then Exit;
FilterList:=TStringList.Create;
try
    ExtractStrings([';'],[' '],PAnsiChar(FFilter),FilterList);
    Result:=FilterList.IndexOf('*'+ExtractFileExt(FileName))<>-1;
finally
    FilterList.Free;
end;
end;

function TDragFileAcceptor.GetDragFileCount(hDrop: THandle): Integer;
const
FILE_INDEX_GET_COUNT:Cardinal=$FFFFFFFF;
begin
Result:=DragQueryFile(hDrop,FILE_INDEX_GET_COUNT,nil,0);
end;

function TDragFileAcceptor.GetDragFileName(hDrop:THandle;iFile:Integer): string;
var
iBufferLen,cbFilled:Integer;
Buf:PAnsiChar;
begin
iBufferLen:=DragQueryFile(hDrop,iFile,nil,0);
Buf:=StrAlloc(iBufferLen+1);
try
    cbFilled:=DragQueryFile(hDrop,iFile,Buf,iBufferLen+1);
    if cbFilled>0 then SetString(Result,Buf,cbFilled)
    else Result:='';
finally
    StrDispose(Buf);
end;
end;

procedure TDragFileAcceptor.HookParent;
begin
if (Owner as TWinControl) <> nil then
begin
    OldWndProc := Pointer(GetWindowLong((Owner as TWinControl).Handle, GWL_WNDPROC));
    NewWndProc := Classes.MakeObjectInstance(HookWndProc);
    SetWindowLong((Owner as TWinControl).Handle, GWL_WNDPROC, LongInt(NewWndProc));
end;
end;

procedure TDragFileAcceptor.HookWndProc(var Msg: TMessage);
begin
case Msg.Msg of
    WM_DROPFILES: DoDragQueryFile(THandle(Msg.WParam));
    WM_DESTROY: if FEnabled then SetEnabled(False);
end;
Msg.Result := CallWindowProc(OldWndProc, (Owner as TWinControl).Handle,
              Msg.Msg, Msg.wParam, Msg.lParam);
end;

procedure TDragFileAcceptor.SetEnabled(const Value: Boolean);
begin
if FEnabled=Value then Exit;
FEnabled := Value;
if csDesigning in ComponentState then Exit;
if FEnabled then AcceptDragFile
else DeAcceptDragFile;
end;

procedure TDragFileAcceptor.SetFilter(const Value: string);
var
temp:string;
begin
if AnsiSameText(Trim(Value),Trim(FFilter)) then Exit;
if Trim(Value)='' then
begin
    FFilter:='*.*';
    Exit;
end;
temp:=Trim(Value);
if ProcessFilter(temp) then
    FFilter:=temp
else
    raise Exception.Create('Invalid file extension filter');
end;

procedure TDragFileAcceptor.UnhookParent;
begin
if ((Owner as TWinControl) <> nil) and Assigned(OldWndProc) then
    SetWindowLong((Owner as TWinControl).Handle, GWL_WNDPROC, LongInt(OldWndProc));
if Assigned(NewWndProc) then
    Classes.FreeObjectInstance(NewWndProc);
NewWndProc := nil;
OldWndProc := nil;
end;
end.