unit DropBMPSource;

// -----------------------------------------------------------------------------
// Project:         Drag and Drop Component Suite
// Component Names: TDropBMPSource
// Module:          DropBMPSource
// Description:     Implements Dragging & Dropping of Bitmaps
//                  FROM your application to another.
// Version:         3.7
// Date:            22-JUL-1999
// Target:          Win32, Delphi 3 - Delphi 5, C++ Builder 3, C++ Builder 4
// Authors:         Angus Johnson,   ajohnson@rpi.net.au
//                  Anders Melander, anders@melander.dk
//                                   http://www.melander.dk
// Copyright        © 1997-99 Angus Johnson & Anders Melander
// -----------------------------------------------------------------------------
// Acknowledgements:
// Thanks to Dieter Steinwedel for some help with DIBs.
// http://godard.oec.uni-osnabrueck.de/student_home/dsteinwe/delphi/DietersDelphiSite.htm
// -----------------------------------------------------------------------------

interface

uses
  DropSource,
  Classes, Graphics, ActiveX;

{$include DragDrop.inc}

type
  TDropBMPSource = class(TDropSource)
  private
    fBitmap: TBitmap;
    procedure SetBitmap(Bmp: TBitmap);
  protected
    function DoGetData(const FormatEtcIn: TFormatEtc; OUT Medium: TStgMedium):HRESULT; Override;
  public
    constructor Create(aOwner: TComponent); Override;
    destructor Destroy; Override;
    function CutOrCopyToClipboard: boolean; Override;
  published
    property Bitmap: TBitmap Read fBitmap Write SetBitmap;
  end;

procedure Register;

implementation

uses
  Windows,
  SysUtils,
  ClipBrd;

procedure Register;
begin
  RegisterComponents('DragDrop', [TDropBMPSource]);
end;

// -----------------------------------------------------------------------------
//     Miscellaneous DIB Function
// -----------------------------------------------------------------------------

function GetHGlobalDIBFromBitmap(Bitmap: Graphics.TBitmap): HGlobal;
var
  Stream: TMemoryStream;
  DIB: pointer;
  DIBSize: integer;
  bfh: TBitmapFileHeader;
begin
  Stream := TMemoryStream.Create;
  try
    //let Graphics.pas do the work...
    Bitmap.SaveToStream(Stream);
    //BitmapFileHeader will be discarded
    DIBSize := Stream.Size - sizeof(TBitmapFileHeader);
    Result:=GlobalAlloc(GMEM_MOVEABLE or GMEM_ZEROINIT or GMEM_SHARE, DIBSize);
    if Result = 0 then exit;
    DIB := GlobalLock(Result);
    if DIB = nil then
    begin
      GlobalFree(Result);
      Result := 0;
    end else
    begin
      Stream.Seek(0,soFromBeginning);
      //skip BitmapFileHeader...
      Stream.readbuffer(bfh,sizeof(TBitmapFileHeader));
      //copy data...
      Stream.readbuffer(DIB^,DIBSize);
      GlobalUnlock(Result);
    end;
  finally
    Stream.free;
  end;
end;

// -----------------------------------------------------------------------------
//			TDropBMPSource
// -----------------------------------------------------------------------------

constructor TDropBMPSource.Create(aOwner: TComponent);
begin
  inherited Create(aOwner);
  fBitmap := Graphics.TBitmap.Create;
  DragTypes := [dtCopy]; // Default to Copy

  AddFormatEtc(CF_BITMAP, NIL, DVASPECT_CONTENT, -1, TYMED_GDI);
  AddFormatEtc(CF_PALETTE, NIL, DVASPECT_CONTENT, -1, TYMED_GDI);
  AddFormatEtc(CF_DIB, NIL, DVASPECT_CONTENT, -1, TYMED_HGLOBAL);
end;
// ----------------------------------------------------------------------------- 

destructor TDropBMPSource.destroy;
begin
  fBitmap.Free;
  inherited Destroy;
end;
// ----------------------------------------------------------------------------- 

procedure TDropBMPSource.SetBitmap(Bmp: Graphics.TBitmap);
begin
  fBitmap.assign(Bmp);
end;
// ----------------------------------------------------------------------------- 

function TDropBMPSource.CutOrCopyToClipboard: boolean;
var
  data: HGlobal;
begin
  result := false;
  if fBitmap.empty then exit;
  try
    data := GetHGlobalDIBFromBitmap(fBitmap);
    if data = 0 then exit;
    Clipboard.SetAsHandle(CF_DIB,data);
    result := true;
  except
    raise Exception.create('Unable to copy BMP to clipboard.');
  end;
end;
// ----------------------------------------------------------------------------- 

function TDropBMPSource.DoGetData(const FormatEtcIn: TFormatEtc; OUT Medium: TStgMedium):HRESULT;
var
  fmt: WORD;
  pal: HPALETTE;
begin

  Medium.tymed := 0;
  Medium.UnkForRelease := nil;
  Medium.HGlobal := 0;
  //--------------------------------------------------------------------------
  if not fBitmap.empty and
     (FormatEtcIn.cfFormat = CF_DIB) and
     (FormatEtcIn.dwAspect = DVASPECT_CONTENT) and
     (FormatEtcIn.tymed and TYMED_HGLOBAL <> 0) then
  begin
    try
      Medium.HGlobal := GetHGlobalDIBFromBitmap(fBitmap);
      if Medium.HGlobal <> 0 then
      begin
        Medium.tymed := TYMED_HGLOBAL;
        result := S_OK
      end else
        result := E_OUTOFMEMORY;
    except
      result := E_OUTOFMEMORY;
    end;
  end
  //--------------------------------------------------------------------------
  else if not fBitmap.empty and
     (FormatEtcIn.cfFormat = CF_BITMAP) and
     (FormatEtcIn.dwAspect = DVASPECT_CONTENT) and
     (FormatEtcIn.tymed and TYMED_GDI <> 0) then
  begin
    try
      //This next line just gets a copy of the bitmap handle...
      fBitmap.SaveToClipboardFormat(fmt, THandle(Medium.hBitmap), pal);
      if pal <> 0 then DeleteObject(pal);
      if Medium.hBitmap <> 0 then
      begin
        Medium.tymed := TYMED_GDI;
        result := S_OK
      end else
        result := E_OUTOFMEMORY;
    except
      result := E_OUTOFMEMORY;
    end;
  end
  //--------------------------------------------------------------------------
  else if not fBitmap.empty and
     (FormatEtcIn.cfFormat = CF_PALETTE) and
     (FormatEtcIn.dwAspect = DVASPECT_CONTENT) and
     (FormatEtcIn.tymed and TYMED_GDI <> 0) then
  begin
    try
      Medium.hBitmap := CopyPalette(fBitmap.palette);
      if Medium.hBitmap <> 0 then
      begin
        Medium.tymed := TYMED_GDI;
        result := S_OK
      end else
        result := E_OUTOFMEMORY;
    except
      result := E_OUTOFMEMORY;
    end {try}
  end else
    result := DV_E_FORMATETC;
end;
// ----------------------------------------------------------------------------- 
// ----------------------------------------------------------------------------- 

end.
