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:=0to StrList.Count-1do begin Result:=Result+StrList[i]; if i<StrList.Count-1then 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:=0to Filter.Count-1do ifnot SingleFilterValid(Filter[i]) then begin Result:=False; Break; end; end; procedure DeleteStringListRedundancy(lst:TStrings); var i:Integer; temp:TStrings; begin if lst.Count=0then Exit; temp:=TStringList.Create; try for i:=0to lst.Count-1do if temp.IndexOf(lst[i])=-1then 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('*.*')<>-1then 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:=0to ComponentCount-1do 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 ornot DirectoryExists(FileName)) and FileMatchFilter(FileName); if Result and Assigned(FOnAcceptFile) then FOnAcceptFile(Self,FileName,Result); end; constructor TDragFileAcceptor.Create(AOwner: TComponent); begin ifnot (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; ifnot (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:=0to GetDragFileCount(hDrop)-1do 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; ifnot 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>0then SetString(Result,Buf,cbFilled) else Result:=''; finally StrDispose(Buf); end; end; procedure TDragFileAcceptor.HookParent; begin if (Owner as TWinControl) <>nilthen 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.