Drag&drop не работает в win8 через idroptarget

Тема в разделе "Delphi - Система", создана пользователем planetoxod, 7 мар 2015.

  1. planetoxod

    planetoxod Member

    Регистрация:
    7 мар 2015
    Сообщения:
    9
    Симпатии:
    0
    Делаю как здесь Your text to link here... под WinXP всё нормально, а в Win8 даже в DragEnter не попадает, чего не хватает?
    Код (Delphi):

    unit UnitDrop;
     
     
     
     
    interface
     
     
     
     
    uses
      Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
      Dialogs, ComCtrls, StdCtrls, Grids, DBGrids, DBCtrls, Spin, ExtDlgs, Jpeg,
      ShellAPI,Buttons, ExtCtrls,ActiveX,ComObj,OleCtrls,OleCtnrs,ComServ;
     
     
     
     
    type
      TfrmDrop = class(TForm,IDropTarget)
        Label1: TLabel;
        procedure FormCreate(Sender: TObject);
        procedure FormClose(Sender: TObject; var Action: TCloseAction);
         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;
      private
        { Private declarations }
      public
        { Public declarations }
      end;
     
    var
      frmDrop: TfrmDrop;
    implementation
     
    {$R *.dfm}
    function TfrmDrop.DragEnter(const dataObj: IDataObject; grfKeyState: Integer;
      pt: TPoint; var dwEffect: Integer): HResult;
    begin
      dwEffect:=DROPEFFECT_COPY;
      Result:=S_OK;
    end;
     
    function TfrmDrop.DragLeave: HResult;
    begin
      Result:=S_OK;
    end;
     
     
    function TfrmDrop.DragOver(grfKeyState: Integer; pt: TPoint;
      var dwEffect: Integer): HResult;
    var
    Koor:TPoint;
    b:boolean;
    a:HWND;
    Sender:TObject;
    begin
    Caption:='X = '+IntToStr(pt.X)+' Y = '+IntToStr(pt.Y);
    dwEffect:=DROPEFFECT_COPY;
      Result:=S_OK;
    end;
     
    procedure TfrmDrop.FormCreate(Sender: TObject);
    begin
    OleInitialize(nil);
    RegisterDragDrop(Handle, Self);
    end;
     
    procedure TfrmDrop.FormClose(Sender: TObject; var Action: TCloseAction);
    begin
    RevokeDragDrop(Handle);
    OleUninitialize;
    end;
     
    function GetUrlW(const DataObj:IDataObject):string;
    var
      FmtEtc:TFormatEtc;
      Medium:TStgMedium;
      g:PChar;
    begin
    Result:='';
    FmtEtc.cfFormat:=CF_TEXT;
    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
        g:=GlobalLock(Medium.hGlobal);
        Result:=String(g);
        GlobalUnlock(Medium.hGlobal);
    {     FileCount := DragQueryFile(Medium.hGlobal, $FFFFFFFF, nil, 0);
          for I := 0 to FileCount-1 do
          begin
            FileNameLength := DragQueryFile(Medium.hGlobal, I, nil, 0);
            SetLength(FileName, FileNameLength);
            DragQueryFile(Medium.hGlobal, I, PChar(FileName), FileNameLength + 1);
            FileList.Add(FileName);
          end;}

       finally
        DragFinish(Medium.hGlobal);
       end;
      finally
       ReleaseStgMedium(Medium);
      end;
    end;
    end;
     
    function TfrmDrop.Drop(const dataObj: IDataObject; grfKeyState: Integer;
      pt: TPoint; var dwEffect: Integer): HResult;
    var
    l:TStringList;
    Koor:TPoint;
    b:boolean;
    a:HWND;
    Sender:TObject;
    s:string;
    begin
    s:=GetUrlW(dataObj);
    if s>'' then Label1.Caption:=s;
    Result:=S_OK;
    end;
     
    end.
    С правами админа для источника и приёмника работает, как без прав, Drag&Drop опера->хром работает без прав?
     
    #1 planetoxod, 7 мар 2015
    Последнее редактирование модератором: 8 мар 2015
Загрузка...

Поделиться этой страницей