jvdragdrop.pas

East make Tray Icon in delphi

  else
  if (Effect and DROPEFFECT_COPY) <> 0 then
    Eff := deCopy
  else
  if (Effect and DROPEFFECT_MOVE) <> 0 then
    Eff := deMove
  else
  if (Effect and DROPEFFECT_LINK) <> 0 then
    Eff := deLink
  else
  if (Effect and DROPEFFECT_SCROLL) <> 0 then
    Eff := deScroll;
end;

procedure SetDropEffect(var Effect: Longint; Eff: TJvDropEffect);
begin
  case Eff of
    deNone:
      Effect := DROPEFFECT_NONE;
    deCopy:
      Effect := DROPEFFECT_COPY;
    deMove:
      Effect := DROPEFFECT_MOVE;
    deLink:
      Effect := DROPEFFECT_LINK;
    deScroll:
      Effect := Longint(DROPEFFECT_SCROLL);
  end;
end;

constructor TJvDropTarget.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Malloc; // a simple call prevents Delphi from crashing

  FAcceptDrag := True;
  FStreamedAcceptDrag := True;

  InitFormatEtc;
end;

destructor TJvDropTarget.Destroy;
begin
  UnregisterControl;
  FDataObject := nil;
  inherited Destroy;
end;

function TJvDropTarget.DragEnter(const dataObj: IDataObject; grfKeyState: Longint;
  pt: TPoint; var dwEffect: Longint): HRESULT;
begin
  FDataObject := dataObj;
  Result := S_OK;

  if not DoDragAccept then
  begin
    FDataObject := nil;
    dwEffect := DROPEFFECT_NONE;
  end
  else
  begin
    dwEffect := DROPEFFECT_COPY;
    try
      DoDragEnter(dwEffect);
    except
      Result := E_UNEXPECTED;
    end;
  end;
end;

function TJvDropTarget.DragOver(grfKeyState: Longint; pt: TPoint;
  var dwEffect: Longint): HRESULT;
begin
  Result := S_OK;
  if FDataObject = nil then
  begin
    FDataObject := nil;
    dwEffect := DROPEFFECT_NONE;
  end
  else
  begin
    dwEffect := DROPEFFECT_COPY;
    try
      DoDragOver(dwEffect);
    except
      Result := E_UNEXPECTED;
    end;
  end;
end;

function TJvDropTarget.DragLeave: HRESULT;
begin
  try
    DoDragLeave;
    Result := S_OK;
  except
    Result := E_UNEXPECTED;
  end;
  FDataObject := nil;
end;

function TJvDropTarget.Drop(const dataObj: IDataObject; grfKeyState: Longint;
  pt: TPoint; var dwEffect: Longint): HRESULT;
begin
  Result := S_OK;
  if FDataObject = nil then
  begin
    FDataObject := nil;
    dwEffect := DROPEFFECT_NONE;
  end
  else
  begin
    dwEffect := DROPEFFECT_COPY;
    try
      DoDragDrop(dwEffect, KeyDataToShiftState(grfKeyState), pt.X, pt.Y);
    except
      Result := E_UNEXPECTED;
    end;
    FDataObject := nil;
  end;
end;

function TJvDropTarget.DoDragAccept: Boolean;
begin
  Result := True;
  if Assigned(FOnDragAccept) then
    FOnDragAccept(Self, Result);
end;

procedure TJvDropTarget.DoDragEnter(var Effect: Longint);
var
  Eff: TJvDropEffect;
begin
  GetDropEffect(Effect, Eff);
  if Assigned(FOnDragEnter) then
    FOnDragEnter(Self, Eff);
  SetDropEffect(Effect, Eff);
end;

procedure TJvDropTarget.DoDragOver(var Effect: Longint);
var
  Eff: TJvDropEffect;
begin
  GetDropEffect(Effect, Eff);
  if Assigned(FOnDragOver) then
    FOnDragOver(Self, Eff);
  SetDropEffect(Effect, Eff);
end;

procedure TJvDropTarget.DoDragLeave;
begin
  if Assigned(FOnDragLeave) then
    FOnDragLeave(Self);
end;

procedure TJvDropTarget.DoDragDrop(var Effect: Longint; Shift: TShiftState;
  X, Y: Integer);
var
  Eff: TJvDropEffect;
begin
  GetDropEffect(Effect, Eff);
  if Assigned(FOnDragDrop) then
    FOnDragDrop(Self, Eff, Shift, X, Y);
  SetDropEffect(Effect, Eff);
end;

procedure TJvDropTarget.SetControl(Value: TWinControl);
begin
  if Value <> FControl then
  begin
    UnregisterControl;
    if Assigned(FControl) then
      FControl.RemoveFreeNotification(Self);

    FControl := Value;

    if Assigned(FControl) then
      FControl.FreeNotification(Self);
      
    RegisterControl;
  end;
end;

procedure TJvDropTarget.RegisterControl;
begin
  if FAcceptDrag and Assigned(FControl) and not (csDesigning in ComponentState) then
  begin
    if RegisterDragDrop(FControl.Handle, Self) <> S_OK then
      RaiseLastOSError;
  end;
end;

procedure TJvDropTarget.UnregisterControl;
begin
  if FAcceptDrag and Assigned(FControl) and not (csDesigning in ComponentState) then
    if FControl.HandleAllocated then
      RevokeDragDrop(FControl.Handle);
end;

procedure TJvDropTarget.SetAcceptDrag(Value: Boolean);
begin
  if csLoading in ComponentState then
    FStreamedAcceptDrag := Value
  else
  if Value <> FAcceptDrag then
  begin
    UnregisterControl;
    FAcceptDrag := Value;
    RegisterControl;
  end;
end;

procedure TJvDropTarget.Loaded;
begin
  inherited Loaded;
  AcceptDrag := FStreamedAcceptDrag;
end;

procedure TJvDropTarget.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if (Operation = opRemove) and (AComponent = FControl) then
    Control := nil;
end;

function TJvDropTarget.GetFileDescrNames(List: TStrings): Integer;
var
  FileGroupDescr: PFileGroupDescriptor;
  Medium: TStgMedium;
  I: Integer;
  S: string;
begin
  Result := 0;
  if FDataObject.GetData(FileDescriptorFormatEtc, Medium) = S_OK then
  begin
    try
      try
        FileGroupDescr := GlobalLock(Medium.hGlobal);
        try
          if List <> nil then
            for I := 0 to FileGroupDescr.cItems - 1 do
            begin
              SetString(S, FileGroupDescr^.fgd[I].cFileName, StrLen(FileGroupDescr^.fgd[I].cFileName));
              List.Add(S);
            end;
          Result := FileGroupDescr.cItems;
        finally
          GlobalUnlock(Medium.hGlobal);
        end;
      finally
        ReleaseStgMedium(Medium);
      end;
    except
      Result := 0;
    end;
  end;
end;

function TJvDropTarget.GetFileDescrCount: Integer;
var
  FileGroupDescr: PFileGroupDescriptor;
  Medium: TStgMedium;
begin
  Result := 0;
  if FDataObject.GetData(FileDescriptorFormatEtc, Medium) = S_OK then
    try
      try
        FileGroupDescr := GlobalLock(Medium.hGlobal);
        try
          Result := FileGroupDescr.cItems;
        finally
          GlobalUnlock(Medium.hGlobal);
        end;
      finally
        ReleaseStgMedium(Medium);
      end;
    except
      Result := 0;
    end;
end;

function TJvDropTarget.GetFilenames(List: TStrings): Integer;
var
  DragH: Integer;
  Medium: TStgMedium;
  Name: string;
  I, Count, Len: Integer;
begin
  Result := 0;
  if FDataObject.GetData(FileDropFormatEtc, Medium) = S_OK then
    try
      try
        DragH := Integer(GlobalLock(Medium.hGlobal));
        try
          Count := DragQueryFile(DragH, Cardinal(-1), nil, 0);
          if List <> nil then
            for I := 0 to Count - 1 do
            begin
              Len := DragQueryFile(DragH, I, nil, 0);
              if Len > 0 then
              begin
                SetLength(Name, Len + 1);
                DragQueryFile(DragH, I, PChar(Name), Len + 1);
                SetLength(Name, Len);
                List.Add(Name);
              end;
            end;
          Result := Count;
        finally
          GlobalUnlock(Medium.hGlobal);
        end;
      finally
        ReleaseStgMedium(Medium);
      end;
    except
      Result := 0;
    end;
end;

function TJvDropTarget.GetFileContent(Index: Integer; Stream: TStream): Boolean;
const
  MaxBufSize = 100 * 1024;
var
  Medium: TStgMedium;
  InStream: IStream;
  Stat: TStatStg;

  Buf: Pointer;
  BufSize: Integer;
  Num: Int64;
  Position: Int64;
begin
  Result := False;
  if (Stream = nil) or (Index < 0) or (Index >= GetFileDescrCount) then
    Exit;

  FileContentFormatEtc.lindex := Index;
  if FDataObject.GetData(FileContentFormatEtc, Medium) = S_OK then
    try
      try
        if Medium.tymed and TYMED_ISTREAM <> 0 then
        begin
          InStream := IStream(Medium.stm);
          InStream.Stat(Stat, STATFLAG_NONAME);
          Num := Stat.cbSize;
          if Num > 0 then
          begin
            GetMem(Buf, MaxBufSize);
            try
             // Speicherbereich reservieren
              Position := Stream.Position;
              Stream.Size := Stream.Size + Num;
              Stream.Position := Position;

              while Num > 0 do
              begin
                if Num < MaxBufSize then
                  BufSize := Num
                else
                  BufSize := MaxBufSize;
                InStream.Read(Buf, BufSize, nil);
                Stream.Write(Buf^, BufSize);
                Dec(Num, BufSize);
              end;
            finally
              FreeMem(Buf);
            end;
          end;
        end
        else
          Result := False;
      finally
        ReleaseStgMedium(Medium);
      end;
    except
      Result := False;
    end;
end;

initialization
  {$IFDEF UNITVERSIONING}
  RegisterUnitVersion(HInstance, UnitVersioning);
  {$ENDIF UNITVERSIONING}
  OleInitialize(nil);

finalization
  OleUninitialize;
  {$IFDEF UNITVERSIONING}
  UnregisterUnitVersion(HInstance);
  {$ENDIF UNITVERSIONING}

end.