hackbard: Drag&Drop File/Image and Read Content

32 Bit Für ältere Compiler Versionen :

Unit UFileCatcher.pas

unit UFileCatcher;

interface

uses
  Windows, ShellAPI;

type
  TFileCatcher = class(TObject)
  private
    fDropHandle: HDROP;
    function GetFile(Idx: Integer): string;
    function GetFileCount: Integer;
    function GetPoint: TPoint;
  public
    constructor Create(DropHandle: HDROP);
    destructor Destroy; override;
    property FileCount: Integer read GetFileCount;
    property Files[Idx: Integer]: string read GetFile;
    property DropPoint: TPoint read GetPoint;
  end;

implementation

{ TFileCatcher }

constructor TFileCatcher.Create(DropHandle: HDROP);
begin
  inherited Create;
  fDropHandle := DropHandle;
end;

destructor TFileCatcher.Destroy;
begin
  DragFinish(fDropHandle);
  inherited;
end;

function TFileCatcher.GetFile(Idx: Integer): string;
var
  FileNameLength: Integer;
begin
  FileNameLength := DragQueryFile(fDropHandle, Idx, nil, 0);
  SetLength(Result, FileNameLength);
  DragQueryFile(fDropHandle, Idx, PChar(Result), FileNameLength + 1);
end;

function TFileCatcher.GetFileCount: Integer;
begin
  Result := DragQueryFile(fDropHandle, $FFFFFFFF, nil, 0);
end;

function TFileCatcher.GetPoint: TPoint;
begin
  DragQueryPoint(fDropHandle, Result);
end;

end.

Unit 1 :

ExtCtrls, ShellAPI, ComCtrls, UFileCatcher

private
    function IsSupportedFileType(const FileName: string): Boolean;
    procedure AddFile(const FileName: string);
    procedure DisplayFile(Idx: Integer);
    procedure WMDropFiles(var Msg: TWMDropFiles); message WM_DROPFILES;
    
const
  cSupportedExts = '*.txt;*.html;*.htm;*.pas;*.inc;*.dpr;';
    
//

procedure TForm1.FormCreate(Sender: TObject);
begin
  DragAcceptFiles(Self.Handle, True);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  DragAcceptFiles(Self.Handle, False);
end;

procedure TForm1.WMDropFiles(var Msg: TWMDropFiles);
var
  I: Integer;
  DropPoint: TPoint;
  Catcher: TFileCatcher;
begin
  inherited;

  Catcher := TFileCatcher.Create(Msg.Drop);
  try
    for I := 0 to Pred(Catcher.FileCount) do
      AddFile(Catcher.Files[I]);
    DropPoint := Catcher.DropPoint;
    ShowMessageFmt('%d file(s) dropped at (%d,%d)',
      [Catcher.FileCount, DropPoint.X, DropPoint.Y]);
  finally
    Catcher.Free;
  end;
  Msg.Result := 0;
end;

procedure TForm1.AddFile(const FileName: string);
begin
  if IsSupportedFileType(FileName) then
    DisplayFile(ListBox1.Items.Add(FileName))
  else
    ShowMessageFmt('File %s is not a supported type', [FileName]);
end;

procedure TForm1.DisplayFile(Idx: Integer);
var
  FileName: string;
begin
  if Idx >= 0 then
  begin
    FileName := ListBox1.Items[Idx];
    ListBox1.ItemIndex := Idx;
    Memo1.Lines.LoadFromFile(FileName);
    StatusBar1.SimpleText := FileName;
  end
  else
  begin
    Memo1.Clear;
    StatusBar1.SimpleText := 'N0 FILE SELECTED';
  end;
end;

function TForm1.IsSupportedFileType(const FileName: string): Boolean;
begin
  Result := AnsiPos('*' + ExtractFileExt(FileName) + ';', cSupportedExts) > 0;
end;

procedure TForm1.ListBox1Click(Sender: TObject);
begin
  DisplayFile(ListBox1.ItemIndex);
end;

64 Bit Für höhere Compiler Versionen mit Bilder laden :

Unit DropTargetFilesPicture.pas

unit DropTargetFilesPicture;

interface

Uses
    ActiveX, Classes, Windows;

type
    TDropTargetFilesPicture = class;

    TDropTargetFilesPictureAccept = (dtfpaFiles, dtfpaPictures);
    TDropTargetFilesPictureAccepts = set of TDropTargetFilesPictureAccept;

    TDropTargetFilesPictureFileNamesCallback = procedure (Sender: TDropTargetFilesPicture; MousePosition: TPoint; FileNames: TStrings) of object;
    TDropTargetFilesPicturePictureCallback = procedure (Sender: TDropTargetFilesPicture; MousePosition: TPoint; FileName: String; Stream: TStream) of object;
    TDropTargetFilesPictureAcceptCallback = procedure (Sender: TDropTargetFilesPicture; const DataObj: IDataObject; MousePosition: TPoint; AcceptType: TDropTargetFilesPictureAccept; var Accept: Boolean) of object;
    TDropTargetFilesPictureDragOverCallback = procedure(Sender: TDropTargetFilesPicture; grfKeyState: Longint; MousePosition: TPoint; var dwEffect: Longint) of object;
    TDropTargetFilesPictureDragLeaveCallback = procedure(Sender: TDropTargetFilesPicture) of object;

    TDropTargetFilesPicture = class(TComponent, IDropTarget)
    private
        CF_FileGroupDescriptor: TClipFormat;
        CF_FileContents: TClipFormat;
        FAccept: Boolean;
        FAccepts: TDropTargetFilesPictureAccepts;
        FOnDropFileNames: TDropTargetFilesPictureFileNamesCallback;
        FOnDropPicture: TDropTargetFilesPicturePictureCallback;
        FOnDropAccept: TDropTargetFilesPictureAcceptCallback;
        FOnDragOver: TDropTargetFilesPictureDragOverCallback;
        FOnDragLeave: TDropTargetFilesPictureDragLeaveCallback;
    protected
        function DragEnter(const dataObj: IDataObject; grfKeyState: Longint; pt: TPoint; var dwEffect: Longint): 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;
    public
        Handles: Array of THandle;
        Constructor Create(AOwner: TComponent); override;
        Destructor Destroy; override;
        function AddDropTargetHandle(AHandle: THandle): Boolean;
        function GetFileListFromObj(const DataObj: IDataObject; const FileList: TStrings): Boolean;
        function GetPictureFileNameFromObj(const DataObj: IDataObject; const FileList: TStrings): Boolean;
        function GetPictureFromObj(const DataObj: IDataObject; Stream: TStream): Boolean;
        function GetBitmapFromObj(const DataObj: IDataObject; Stream: TStream): Boolean;
    published
        property Accepts: TDropTargetFilesPictureAccepts read FAccepts write FAccepts;
        property OnDropFileNames: TDropTargetFilesPictureFileNamesCallback read FOnDropFileNames write FOnDropFileNames;
        property OnDropPicture: TDropTargetFilesPicturePictureCallback read FOnDropPicture write FOnDropPicture;
        property OnDropAccept: TDropTargetFilesPictureAcceptCallback read FOnDropAccept write FOnDropAccept;
        property OnDragOver: TDropTargetFilesPictureDragOverCallback read FOnDragOver write FOnDragOver;
        property OnDragLeave: TDropTargetFilesPictureDragLeaveCallback read FOnDragLeave write FOnDragLeave;
    end;

    procedure Register;

implementation

Uses
    SysUtils, Graphics, ShlObj, ShellAPI, Controls;

procedure Register;
begin
    RegisterComponents('3delite', [TDropTargetFilesPicture]);
end;

function TDropTargetFilesPicture.AddDropTargetHandle(AHandle: THandle): Boolean;
begin
    Result := RegisterDragDrop(AHandle, Self) = S_OK;
    if Result then begin
        SetLength(Handles, Length(Handles) + 1);
        Handles[Length(Handles) - 1] := AHandle;
    end;
end;

constructor TDropTargetFilesPicture.Create(AOwner: TComponent);
begin
    inherited;
    FAccepts := [dtfpaFiles, dtfpaPictures];
    CF_FileGroupDescriptor := RegisterClipboardFormat('FileGroupDescriptorW');
    CF_FileContents := RegisterClipboardFormat('FileContents');
    //CF_DC := RegisterClipboardFormat('DragContext');
end;

destructor TDropTargetFilesPicture.Destroy;
var
    i: Integer;
begin
    for i := Low(Handles) to High(Handles) do begin
        RevokeDragDrop(Handles[i]);
    end;
    inherited;
end;

function TDropTargetFilesPicture.DragEnter(const dataObj: IDataObject; grfKeyState: Longint; pt: TPoint; var dwEffect: Longint): HResult;
var
    FmtEtc: TFormatEtc;
    Medium: TStgMedium;
begin
    FAccept := False;
    dwEffect := DROPEFFECT_NONE;
    if dtfpaFiles in FAccepts then begin
        FmtEtc.cfFormat := CF_HDROP;
        FmtEtc.ptd := nil;
        FmtEtc.dwAspect := DVASPECT_CONTENT;
        FmtEtc.lindex := -1;
        FmtEtc.tymed := TYMED_HGLOBAL;
        if DataObj.GetData(FmtEtc, Medium) = S_OK then begin
            FAccept := True;
            if Assigned(FOnDropAccept) then begin
                FOnDropAccept(Self, DataObj, pt, dtfpaFiles, FAccept);
            end;
            if FAccept then begin
                dwEffect := DROPEFFECT_COPY;
            end;
            ReleaseStgMedium(Medium);
        end;
    end;
    if dtfpaPictures in FAccepts then begin
        FmtEtc.cfFormat := CF_FileContents;
        FmtEtc.ptd := nil;
        FmtEtc.dwAspect := DVASPECT_CONTENT;
        FmtEtc.lindex := 0;
        FmtEtc.tymed := TYMED_HGLOBAL;
        if DataObj.GetData(FmtEtc, Medium) = S_OK then begin
            FAccept := True;
            if Assigned(FOnDropAccept) then begin
                FOnDropAccept(Self, DataObj, pt, dtfpaPictures, FAccept);
            end;
            if FAccept then begin
                dwEffect := DROPEFFECT_COPY;
            end;
            ReleaseStgMedium(Medium);
        end;
    end;
    Result := S_OK;
end;

function TDropTargetFilesPicture.DragLeave: HResult;
begin
    if Assigned(FOnDragLeave) then begin
        FOnDragLeave(Self);
    end;
    Result := S_OK;
end;

function TDropTargetFilesPicture.DragOver(grfKeyState: Longint; pt: TPoint; var dwEffect: Longint): HResult;
begin
    dwEffect := DROPEFFECT_COPY;
    if Assigned(FOnDragOver) then begin
        FOnDragOver(Self, grfKeyState, pt, dwEffect);
    end;
    Result := S_OK;
end;

function TDropTargetFilesPicture.Drop(const dataObj: IDataObject; grfKeyState: Longint; pt: TPoint; var dwEffect: Longint): HResult;
var
    Enum: IEnumFormatEtc;
    FileNameList: TStrings;
    PictureStream: TMemoryStream;
    FileName: String;
begin
    dwEffect := DROPEFFECT_COPY;
    if DataObj.EnumFormatEtc(DATADIR_GET, Enum) = S_OK then begin
        FileNameList := TStringList.Create;
        PictureStream := TMemoryStream.Create;
        try
            if dtfpaFiles in FAccepts then begin
                if GetFileListFromObj(dataObj, FileNameList) then begin
                    if Assigned(FOnDropFileNames) then begin
                        FOnDropFileNames(Self, pt {Mouse.CursorPos}, FileNameList);
                    end;
                end;
            end;
            if dtfpaPictures in FAccepts then begin
                GetPictureFileNameFromObj(dataObj, FileNameList);
                if GetPictureFromObj(dataObj, PictureStream) then begin
                    if Assigned(FOnDropPicture) then begin
                        if FileNameList.Count > 0 then begin
                           FileName := FileNameList[0];
                        end;
                        FOnDropPicture(Self, pt {Mouse.CursorPos}, FileName, PictureStream);
                    end;
                end;
                if GetBitmapFromObj(dataObj, PictureStream) then begin
                    if Assigned(FOnDropPicture) then begin
                        FOnDropPicture(Self, pt {Mouse.CursorPos}, FileName, PictureStream);
                    end;
                end;
            end;
        finally
            FreeAndNil(PictureStream);
            FreeAndNil(FileNameList);
        end;
    end;
    Result := S_OK;
end;

function TDropTargetFilesPicture.GetFileListFromObj(const DataObj: IDataObject; const FileList: TStrings): Boolean;
var
    FmtEtc: TFormatEtc;
    Medium: TStgMedium;
    DroppedFileCount: Integer;
    i: Integer;
    FileNameLength: Integer;
    FileName: string;
begin
    Result := False;
    FmtEtc.cfFormat := CF_HDROP;
    FmtEtc.ptd := nil;
    FmtEtc.dwAspect := DVASPECT_CONTENT;
    FmtEtc.lindex := -1;
    FmtEtc.tymed := TYMED_HGLOBAL;
    if DataObj.GetData(FmtEtc, Medium) = S_OK then begin
        try
            try
                DroppedFileCount := DragQueryFile(Medium.hGlobal, $FFFFFFFF, nil, 0);
                for i := 0 to Pred(DroppedFileCount) do begin
                    FileNameLength := DragQueryFile(Medium.hGlobal, i, nil, 0);
                    SetLength(FileName, FileNameLength);
                    DragQueryFile(Medium.hGlobal, i, PChar(FileName), FileNameLength + 1);
                    FileList.Add(FileName);
                    Result := True;
                end;
            finally
                DragFinish(Medium.hGlobal);
            end;
        finally
            ReleaseStgMedium(Medium);
        end;
    end;
end;

function TDropTargetFilesPicture.GetPictureFileNameFromObj(const DataObj: IDataObject; const FileList: TStrings): Boolean;
var
    FmtEtc: TFormatEtc;
    Medium: TStgMedium;
    PData: PChar;
begin
    Result := False;
    FmtEtc.cfFormat := CF_FileGroupDescriptor;
    FmtEtc.ptd := nil;
    FmtEtc.dwAspect := DVASPECT_CONTENT;
    FmtEtc.lindex := - 1;
    FmtEtc.tymed := TYMED_HGLOBAL;
    if DataObj.GetData(FmtEtc, Medium) = S_OK then begin
        try
            PData := GlobalLock(Medium.hGlobal);
            try
                FileList.Append(PFileGroupDescriptorW(PData).fgd[0].cFileName);
                Result := True;
            finally
                GlobalUnlock(Medium.hGlobal);
            end;
        finally
            ReleaseStgMedium(Medium);
        end;
    end;
end;

function TDropTargetFilesPicture.GetPictureFromObj(const DataObj: IDataObject; Stream: TStream): Boolean;
var
    FmtEtc: TFormatEtc;
    Medium: TStgMedium;
    PData: PChar;
    MemSize: NativeUInt;
begin
    Result := False;
    FmtEtc.cfFormat := CF_FileContents;
    FmtEtc.ptd := nil;
    FmtEtc.dwAspect := DVASPECT_CONTENT;
    FmtEtc.lindex := 0;
    FmtEtc.tymed := TYMED_HGLOBAL;
    if DataObj.GetData(FmtEtc, Medium) = S_OK then begin
        try
            PData := GlobalLock(Medium.hGlobal);
            try
                MemSize := GlobalSize(Medium.hGlobal);
                Stream.Write(PData^, MemSize);
                Stream.Seek(0, soBeginning);
                Result := True;
            finally
                GlobalUnlock(Medium.hGlobal);
            end;
        finally
            ReleaseStgMedium(Medium);
        end;
    end;
end;

function DIBGetData(const ADataObject: IDataObject; const AMedium: TStgMedium; Stream: TMemoryStream): Boolean;
var
    BitmapInfo: PBitmapInfo;
    BitmapFileHeader: TBitmapFileHeader;
    DIBSize: integer;
    FileSize: integer;
    InfoSize: integer;
begin
    Result := False;
    BitmapInfo := GlobalLock(AMedium.HGlobal);
    try
        if (BitmapInfo = nil) then begin
            Exit;
        end;
        DIBSize := GlobalSize(AMedium.HGlobal);
        FileSize := SizeOf(TBitmapFileHeader) + DIBSize;
        InfoSize := SizeOf(TBitmapInfoHeader);
        if (BitmapInfo^.bmiHeader.biBitCount > 8) then begin
            if ((BitmapInfo^.bmiHeader.biCompression and BI_BITFIELDS) <> 0) then begin
                Inc(InfoSize, 12);
            end else begin
                Inc(InfoSize, SizeOf(TRGBQuad) * (1 shl BitmapInfo^.bmiHeader.biBitCount));
            end;
        end;
        Stream.SetSize(FileSize);
        FillChar(BitmapFileHeader, SizeOf(TBitmapFileHeader), 0);
        with BitmapFileHeader do begin
            bfType := $4D42;
            bfSize := FileSize;
            bfOffBits := SizeOf(TBitmapFileHeader) + InfoSize;
        end;
        Stream.Write(BitmapFileHeader, SizeOf(TBitmapFileHeader));
        Stream.Write(BitmapInfo^, DIBSize);
        Stream.Seek(0, soBeginning);
        Result := True;
    finally
        GlobalUnlock(AMedium.HGlobal);
    end;
end;

function TDropTargetFilesPicture.GetBitmapFromObj(const DataObj: IDataObject; Stream: TStream): Boolean;
var
    FmtEtc: TFormatEtc;
    Medium: TStgMedium;
begin
    Result := False;
    FmtEtc.cfFormat := CF_DIB;
    FmtEtc.ptd := nil;
    FmtEtc.dwAspect := DVASPECT_CONTENT;
    FmtEtc.lindex := - 1;
    FmtEtc.tymed := TYMED_HGLOBAL;
    if DataObj.GetData(FmtEtc, Medium) = S_OK then begin
        try
            Result := DIBGetData(DataObj, Medium, Stream as TMemoryStream);
        finally
            ReleaseStgMedium(Medium);
        end;
    end;
end;

Initialization

    OleInitialize(nil);

Finalization

    OleUninitialize;

end.

Unit1 :

uses uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
  System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs,
  Vcl.ExtCtrls, Vcl.StdCtrls, DropTargetFilesPicture, JPEG, PNGImage;
  
private
    { Private declarations }
    DropTargetFilesPicture: TDropTargetFilesPicture;
  protected
    procedure DropFileNamesCallback(Sender: TDropTargetFilesPicture; MousePosition: TPoint; FileNames: TStrings);
    procedure DropPictureCallback(Sender: TDropTargetFilesPicture; MousePosition: TPoint; FileName: String; Stream: TStream);
    
//

procedure TForm1.FormCreate(Sender: TObject);
begin
    DropTargetFilesPicture := TDropTargetFilesPicture.Create(Self);
    DropTargetFilesPicture.OnDropFileNames := DropFileNamesCallback;
    DropTargetFilesPicture.OnDropPicture := DropPictureCallback;
    DropTargetFilesPicture.AddDropTargetHandle(Handle);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
    FreeAndNil(DropTargetFilesPicture);
end;

procedure TForm1.DropFileNamesCallback(Sender: TDropTargetFilesPicture; MousePosition: TPoint; FileNames: TStrings);
begin
    Memo1.Lines.Clear;
    Image1.Picture.Assign(nil);
    Memo1.Lines.Assign(FileNames);
    Memo2.Lines.LoadFromFile(Memo1.Lines[0]);
    Image1.Picture.LoadFromFile(Memo1.Lines[0]);
end;

procedure TForm1.DropPictureCallback(Sender: TDropTargetFilesPicture; MousePosition: TPoint; FileName: String; Stream: TStream);
begin
    Memo1.Lines.Clear;
    Image1.Picture.Assign(nil);
    Memo1.Lines.Append(FileName);
    Image1.Picture.LoadFromStream(Stream);
end;

hackbard

Drag&Drop File/Image and Read Content

Keine Kommentare:

Kommentar veröffentlichen

Beliebte Posts

Translate