Drag and drop depuis une application externe et l'explorer windows

Télécharger le projet
Commenter

Description

Voici une micro application qui montre comment mettre en place proprement la gestion d'un drop depuis une application extérieure ou l'explorer windows.

j'ai aussi mis en place une fonction qui permet d'envoyer à un serveur distant, via un script php situé sur le-dit serveur, le fichier courant droppé. Pour l'explorer il marche parfaitement par contre en ce qui concerne une application externe (par exemple firefox), il ne fonctionne pour l'instant que pour les images, mais j'entends bien l'étendre à tous types de fichiers (pdf, doc, zip, rar, etc...).

Afin de mettre en oeuvre ce dernier point, il faut disposer d'un serveur (par exemple EasyPhp) et crée un dossier "/upload" dans lequel il faut mettre le script "uploadfile.php" que vous trouverez dans le dossier "script_php".

Remarque : l'application fonctionne sans ça quand même mais vous ne pourrez pas réaliser l'upload.

++

Source / Exemple : 


unit F_main;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls, ComCtrls, ActiveX, ShlObj, GraphicEx, GIFImage,
  IdBaseComponent, IdComponent, IdTCPConnection, IdTCPClient, IdHTTP,
  IdMultipartFormData;

type
  TfmMain = class(TForm, IDropTarget)
    Panel1: TPanel;
    GroupBox1: TGroupBox;
    GroupBox2: TGroupBox;
    bSendFile: TButton;
    img: TImage;
    mo: TMemo;
    edUrl: TEdit;
    idh: TIdHTTP;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure bSendFileClick(Sender: TObject);

  private
    { Déclarations privées }
    isImage : boolean;
    procedure EnumDataObject(dataObj : IDataObject);
    procedure HandleText(dataObj : IDataObject; fetc : TFormatEtc);
    procedure HandleRTF(dataObj : IDataObject; fetc : TFormatEtc);
    procedure HandleBMP(dataObj : IDataObject; fetc : TFormatEtc);
    procedure HandleHTML(dataObj : IDataObject; fetc : TFormatEtc);
    procedure HandleHDrop(dataObj : IDataObject; fetc : TFormatEtc);
    procedure ClearOldInfo;
    procedure Send_to_servor(filename : String);

  public
    { Déclarations publiques }
    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;

  end;

var
  fmMain: TfmMain;

implementation

{$R *.dfm}

////////////
// UTILS: //
////////////

//
//  Rappel sur la structure TFormatEtc:
//
//  tagFORMATETC = record
//    cfFormat: TClipFormat;
//    ptd: PDVTargetDevice;
//    dwAspect: Longint;
//    lindex: Longint;
//    tymed: Longint;
//  end;
//  TFormatEtc = tagFORMATETC;
//

function StringFromTymed(Tymed : integer) : string;
begin
  case Tymed of
    0 : Result := 'TYMED_NULL';     // No data transfered
    1 : Result := 'TYMED_HGLOBAL';  // Data transfered in global memory
    2 : Result := 'TYMED_FILE';     // Data is in a standard disk file
    4 : Result := 'TYMED_ISTREAM';  // Data transfered in an OLE stream
    8 : Result := 'TYMED_ISTORAGE'; // Data transfered in an OLE storage
    16 : Result := 'TYMED_GDI';     // Data transfered as a standard windows GDI object
    32 : Result := 'TYMED_MFPICT';  // Data is a metafile in global memory
    64 : Result := 'TYMED_ENHMF';   // Data is an extended metafile in global memory
    else
      result := 'Unknown TYMED';
  end;
end;

function StringFromClipboardFormat(cf : Word; AndNumber : boolean) : string;
var
  sz : array[ 0..300 ] of char;
begin
  {Check if the data is one of the basic clipboard formats}
  case (cf) of
    CF_DIF          : result := 'CF_DIF';
    CF_DIB          : result := 'CF_DIB';
    CF_TEXT         : result := 'CF_TEXT';
    CF_SYLK         : result := 'CF_SYLK';
    CF_TIFF         : result := 'CF_TIFF';
    CF_RIFF         : result := 'CF_RIFF';
    CF_WAVE         : result := 'CF_WAVE';
    CF_HDROP        : result := 'CF_HDROP';
    CF_BITMAP       : result := 'CF_BITMAP';
    CF_LOCALE       : result := 'CF_LOCALE';
    CF_OEMTEXT      : result := 'CF_OEMTEXT';
    CF_PALETTE      : result := 'CF_PALETTE';
    CF_PENDATA      : result := 'CF_PENDATA';
    CF_UNICODETEXT  : result := 'CF_UNICODETEXT';
    CF_ENHMETAFILE  : result := 'CF_ENHMETAFILE';
    CF_METAFILEPICT : result := 'CF_METAFILEPICT';
  else begin
    {Data type not found, so get the description for this data type}
    GetClipboardFormatName(cf, @sz, 200);
    {Add the numeric value of the item?}
    if(AndNumber) then
      result := '[' + IntToStr(cf) + '] ' + sz
    else
      Result := sz;
    end;
  end;
end;

function StringFromAspect(Aspect : Word) : string;
begin
  case (Aspect) of
    1 : result := 'DVASPECT_CONTENT';   // All data is included
    2 : result := 'DVASPECT_THUMBNAIL'; // A thumbnail of the data is included
    4 : result := 'DVASPECT_ICON';      // An icon representing the data is included
    8 : result := 'DVASPECT_DOCPRINT';  // A full printer document is included. That is a header, page numbers, footers etc.
  else
    result := 'Unknown Aspect';
  end;
end;

function StringFromTD(td : Pointer) : string;
begin
  if(td <> nil) then
    result := 'NON-NULL'
  else
    result := 'NULL';
end;

//
// Permet d'extraire le nom du fichier contenu dans un lien URL ou un simple
// chemin.
//
function ExtractFileNameInURL(const cs_URL: String): String;
begin
  Result:= Copy(cs_URL, LastDelimiter('\/:', cs_URL) + 1, Length(cs_URL))
end;

///////////
// TYPE: //
///////////

procedure TfmMain.FormCreate(Sender: TObject);
var
  res : HRESULT;
begin
  OleInitialize(nil);
  res := RegisterDragDrop(Handle, self);
  if (Failed(res)) then
    ShowMessage('RegisterDragDrop failed.');
end;

procedure TfmMain.FormDestroy(Sender: TObject);
begin
  RevokeDragDrop(Handle);
  OleUninitialize;
end;

//////////////
// PRIVATE: //
//////////////

//
// Traitement de l'objet droppé dans l'applcation en fonction de son type
//
//  - CF_TEXT : l'objet est du texte simple
//  - CF_BITMAP : l'objet est une image au format ".BMP"
//  - CF_HDROP : l'objet provient de l'explorer windows
//  - "Rich Text Format" : l'objet est du texte au format "RTF"
//  - "HTML Format" : l'objet provient d'Internet (texte, html, url)
//
procedure TfmMain.EnumDataObject(dataObj : IDataObject);
var
  ef : IEnumFORMATETC;
  fetc : TFORMATETC;
  sFormat : string;
  bNotFound : boolean;
begin
  if (dataObj = nil) then
  begin
    ShowMessage('dataObj = nil');
    exit;
  end;
  {On récupère l'interface IEnumFORMATETC, que l'on stocke dans ef}
  dataObj.EnumFormatEtc(DATADIR_GET, ef);
  {Début de l'énumération}
  while(ef.Next(1, fetc, nil) <> S_FALSE) do
  begin
    bNotFound := false;
    {Le format de l'objet est un format standard}
    case fetc.cfFormat of
      CF_TEXT   : HandleText(dataObj, fetc);
      CF_BITMAP : HandleBMP(dataObj, fetc);
      CF_HDROP  : HandleHDrop(dataObj, fetc);
    else
      bNotFound := true;
  end;
  if (bNotFound) then
  begin
    {Détection du format dans le cas où on ne l'a pas trouver précédemment}
    sFormat := StringFromClipboardFormat(fetc.cfFormat, false);
    if (sFormat = 'Rich Text Format') then
      HandleRTF(dataObj, fetc);
    if (sFormat = 'HTML Format') then
      HandleHTML(dataObj, fetc);
    end;
  end;
end;

//
// CF_TEXT
//
procedure TfmMain.HandleText(dataObj : IDataObject; fetc : TFormatEtc);
var
  p : pointer;
  stgm : TSTGMEDIUM;
begin
  ShowMessage('CF_TEXT');
  {On vérfie que le format est correct}
  if (dataObj.QueryGetData(fetc) = NOERROR) then
  begin
    {Si il s'agit d'un lien vers une image et qu'on l'a déjà affichée, on sort}
    if (isImage) then
      exit;

    {On récupère les données contenues dans l'objet}
    dataObj.GetData(fetc, stgm);
    {On bloque la mémoire globale pour obtenir un pointeur vers les données}
    p := GlobalLock(stgm.hGlobal);

    mo.Visible := true;
    {On récupère le texte}
    mo.Text := string(p);

    {On a finit le traitement donc on débloque la mémoire globale}
    GlobalFree(stgm.hGlobal);
    {On libère la mémoire}
    ReleaseStgMedium(stgm);
   end;
end;

//
// "Rich Text Format"
//
procedure TfmMain.HandleRTF(dataObj : IDataObject; fetc : TFormatEtc);
var
  p : pointer;
  stgm : TSTGMEDIUM;
  mstrm : TMemoryStream;
begin
  ShowMessage('Rich Text Format');
  if (dataObj.QueryGetData(fetc) = NOERROR) then
  begin
    dataObj.GetData(fetc, stgm);
    p := GlobalLock(stgm.hGlobal);

    // TODO: Traitement pour un RTF

    GlobalFree(stgm.hGlobal);
    ReleaseStgMedium(stgm);
  end;
end;

//
// CF_BITMAP
//
procedure TfmMain.HandleBMP(dataObj : IDataObject; fetc : TFormatEtc);
var
  stgm : TSTGMEDIUM;
begin
  ShowMessage('CF_BMP');
  if (dataObj.QueryGetData(fetc) = NOERROR) then
  begin
    dataObj.GetData(fetc, stgm);

    img.Visible := true;
    img.Picture.Bitmap.Handle := stgm.hBitmap;
    img.Refresh;

    ReleaseStgMedium(stgm);
  end;
end;

//
// "HTML Format"
//
procedure TfmMain.HandleHTML(dataObj : IDataObject; fetc : TFormatEtc);
var
  p : pointer;
  stgm : TSTGMEDIUM;
begin
  ShowMessage('HTML Format');
  if(dataObj.QueryGetData(fetc) = NOERROR) then
  begin
    {Si il s'agit d'un lien vers une image et qu'on l'a déjà affichée, on sort}
    if (isImage) then
      exit;

    dataObj.GetData(fetc, stgm);
    p := GlobalLock(stgm.hGlobal);

    mo.Visible := true;
    mo.Text := string(p);

    GlobalFree(stgm.hGlobal);
    ReleaseStgMedium(stgm);
  end;
end;

//
// CF_HDROP
//
procedure TfmMain.HandleHDrop(dataObj : IDataObject; fetc : TFormatEtc);
var
  pdf : PDropFiles;
  stgm : TSTGMEDIUM;
  pFiles : PChar;
  filename : string;
  GraphicClass : TGraphicExGraphicClass;
  Graphic: TGraphic;
begin
  ShowMessage('CF_HDROP');
  if(dataObj.QueryGetData(fetc) = NOERROR) then
  begin
    dataObj.GetData(fetc, stgm);
    pdf := GlobalLock(stgm.hGlobal);

    {On récupère le chemin du fichier/dossier droppé}
    filename := '';
    pFiles := pointer(integer(pointer(pdf)) + pdf^.pFiles);
    repeat
      filename := filename + pFiles;
      pFiles := pointer(integer(pFiles) + Length(string(pFiles)) + 1);
    until(pFiles^ = #0);
    edUrl.Text := filename;
    bSendFile.Enabled := true;

    {Si c'est une image on l'affiche}
    GraphicClass := FileFormatList.GraphicFromContent(filename);
    if GraphicClass = nil then
    begin
      try
        img.Visible := true;
        img.Picture.LoadFromFile(filename);
        isImage := true;
      except
        on e : Exception do begin
          img.Picture := nil;
        end
      end
    end else begin
      Graphic := GraphicClass.Create;
      Graphic.LoadFromFile(filename);
      img.Picture.Graphic := Graphic;
    end;

    GlobalFree(stgm.hGlobal);
    ReleaseStgMedium(stgm);
  end;
end;

//
// Réinitialise les composants de l'application en préambule d'un drop.
//
procedure TfmMain.ClearOldInfo();
begin
  {On efface l'url}
  edUrl.Text := '';
  {On efface et on cache le memo}
  mo.Clear;
  mo.Visible := false;
  {On efface et on cache l'image}
  isImage := false;
  img.Picture := nil;
  img.Visible := false;
  {On désactive le bouton "Send to the server"}
  bSendFile.Enabled := false;
end;

//
// Envoies le fichier courant au serveur.
//
// - script contient le chemin du script "uploadfile.php" qui va récupérer les
// données envoyées par l'application.
// - dir indique le répertoire final dans lequel sera socké le fichier envoyé
// sur le serveur.
//
procedure TfmMain.Send_to_servor(filename : String);
var
  MultiPartFormDataStream: TIdMultiPartFormDataStream;
  Response: TStringStream;
  dir : string;
  script : string;
begin
  script := 'http://127.0.0.1/upload/uploadfile.php';
  MultiPartFormDataStream := TIdMultiPartFormDataStream.Create;
  Response := TStringStream.Create('');
  try
    dir := ExtractFileDir(Application.ExeName) + '/test';
    {Remplis la variable dossier pour spécifier l'upload dans "/test"}
    MultiPartFormDataStream.AddFormField('dossier',dir);
    {Joint le fichier}
    MultiPartFormDataStream.AddFile('userfile', filename, 'multipart/form-data');
    MultiPartFormDataStream.Position := 0;
    {Envoi du fichier via le script php situé sur le serveur}
    try
      idh.Post(script, MultiPartFormDataStream, Response);
      ShowMessage(Response.DataString);
    except
      on e:Exception do
        ShowMessage(e.Message);
    end;
  finally
    MultiPartFormDataStream.Free;
    Response.free;
  end;
end;

/////////////
// PUBLIC: //
/////////////

function TfmMain.DragEnter(const dataObj: IDataObject;grfKeyState: Longint; pt: TPoint; var dwEffect: Longint): HResult; stdcall;
begin
  {On indique que l'effet d'un drop dans l'application sera de copier l'objet}
  dwEffect := DROPEFFECT_COPY;
  result := S_OK;
end;

function TfmMain.DragOver(grfKeyState: Longint; pt: TPoint; var dwEffect: Longint): HResult; stdcall;
begin
  {On indique que l'effet d'un drop dans l'application sera de copier l'objet}
  dwEffect := DROPEFFECT_COPY;
  result := S_OK;
end;

function TfmMain.DragLeave: HResult; stdcall;
begin
  result := S_OK;
end;

function TfmMain.Drop(const dataObj: IDataObject; grfKeyState: Longint; pt: TPoint; var dwEffect: Longint): HResult; stdcall;
begin
  {On réinitialise les composants de l'application}
  ClearOldInfo;
  {On effectue les traitements en fonction du type de l'objet droppé}
  EnumDataObject(dataObj);
  result := S_OK;
end;

procedure TfmMain.bSendFileClick(Sender: TObject);
begin
  {On envoie le fichier courant sur le serveur}
  if (edUrl.Text <> '') then
    Send_to_servor(edUrl.Text);
end;

end.
Télécharger le projet

Codes Sources

A voir également

S'inscrire maintenant

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.