unit DropBMPTarget;
// -----------------------------------------------------------------------------
// 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
// -----------------------------------------------------------------------------
interface
uses
DropSource,
DropTarget,
Windows, Classes, Graphics, ActiveX;
{$include DragDrop.inc}
type
TDropBMPTarget = class(TDropTarget)
private
fBitmap: TBitmap;
protected
procedure ClearData; override;
function DoGetData: boolean; override;
function HasValidFormats: boolean; override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
property Bitmap: TBitmap Read fBitmap;
end;
procedure Register;
procedure CopyDIBToBitmap(Bitmap: TBitmap; BitmapInfo: PBitmapInfo; DIBSize: integer);
implementation
const
DIBFormatEtc: TFormatEtc = (cfFormat: CF_DIB;
ptd: nil; dwAspect: DVASPECT_CONTENT; lindex: -1; tymed: TYMED_HGLOBAL);
BMPFormatEtc: TFormatEtc = (cfFormat: CF_BITMAP;
ptd: nil; dwAspect: DVASPECT_CONTENT; lindex: -1; tymed: TYMED_GDI);
PalFormatEtc: TFormatEtc = (cfFormat: CF_PALETTE;
ptd: nil; dwAspect: DVASPECT_CONTENT; lindex: -1; tymed: TYMED_GDI);
procedure Register;
begin
RegisterComponents('DragDrop', [TDropBMPTarget]);
end;
// -----------------------------------------------------------------------------
// Miscellaneous DIB Function
// -----------------------------------------------------------------------------
procedure CopyDIBToBitmap(Bitmap: TBitmap; BitmapInfo: PBitmapInfo; DIBSize: integer);
var
BitmapFileHeader : TBitmapFileHeader;
FileSize : integer;
InfoSize : integer;
Stream : TMemoryStream;
begin
// Write DIB to a stream in the BMP file format
Stream := TMemoryStream.Create;
try
FileSize := sizeof(TBitmapFileHeader) + DIBSize;
InfoSize := sizeof(TBitmapInfoHeader);
if (BitmapInfo^.bmiHeader.biBitCount > 8) then
begin
if ((BitmapInfo^.bmiHeader.biCompression and BI_BITFIELDS) <> 0) then
Inc(InfoSize, 12);
end else
Inc(InfoSize, sizeof(TRGBQuad) * (1 shl BitmapInfo^.bmiHeader.biBitCount));
Stream.SetSize(FileSize);
// Initialize file header
FillChar(BitmapFileHeader, sizeof(TBitmapFileHeader), 0);
with BitmapFileHeader do
begin
bfType := $4D42; // 'BM' = Windows BMP signature
bfSize := FileSize; // File size (not needed)
bfOffBits := sizeof(TBitmapFileHeader) + InfoSize; // Offset of pixel data
end;
// Save file header
Stream.Write(BitmapFileHeader, sizeof(TBitmapFileHeader));
// Save TBitmapInfo structure and pixel data
Stream.Write(BitmapInfo^, DIBSize);
// Rewind and load bitmap from stream
Stream.Position := 0;
Bitmap.LoadFromStream(Stream);
finally
Stream.Free;
end;
end;
// -----------------------------------------------------------------------------
// TDropBMPTarget
// -----------------------------------------------------------------------------
constructor TDropBMPTarget.Create( AOwner: TComponent );
begin
inherited Create( AOwner );
fBitmap := TBitmap.Create;
end;
// -----------------------------------------------------------------------------
destructor TDropBMPTarget.Destroy;
begin
fBitmap.Free;
inherited Destroy;
end;
// -----------------------------------------------------------------------------
function TDropBMPTarget.HasValidFormats: boolean;
begin
result := (DataObject.QueryGetData(DIBFormatEtc) = S_OK) or
(DataObject.QueryGetData(BMPFormatEtc) = S_OK);
end;
// -----------------------------------------------------------------------------
procedure TDropBMPTarget.ClearData;
begin
fBitmap.handle := 0;
end;
// -----------------------------------------------------------------------------
function TDropBMPTarget.DoGetData: boolean;
var
medium, medium2: TStgMedium;
DIBData: pointer;
begin
result := false;
//--------------------------------------------------------------------------
if (DataObject.GetData(DIBFormatEtc, medium) = S_OK) then
begin
if (medium.tymed = TYMED_HGLOBAL) then
begin
DIBData := GlobalLock(medium.HGlobal);
try
CopyDIBToBitmap(fBitmap, DIBData, GlobalSize(Medium.HGlobal));
result := true;
finally
GlobalUnlock(medium.HGlobal);
end;
end;
ReleaseStgMedium(medium);
end
//--------------------------------------------------------------------------
else if (DataObject.GetData(BMPFormatEtc, medium) = S_OK) then
begin
try
if (medium.tymed <> TYMED_GDI) then exit;
if (DataObject.GetData(PalFormatEtc, medium2) = S_OK) then
begin
try
fBitmap.LoadFromClipboardFormat(CF_BITMAP, Medium.hBitmap, Medium2.hBitmap);
finally
ReleaseStgMedium(medium2);
end;
end
else
fBitmap.LoadFromClipboardFormat(CF_BITMAP, Medium.hBitmap, 0);
result := true;
finally
ReleaseStgMedium(medium);
end;
end
//--------------------------------------------------------------------------
else
result := false;
end;
// -----------------------------------------------------------------------------
// -----------------------------------------------------------------------------
end.