Mega Code Archive
Bitmapcursor
<![CDATA[
unit MainUnit;
//Richard Ebbs
//ELIS February 2001
//small test app to work on setting
//up drag and drop with a 'bitmap cursor'
//WITHOUT using the built in Delphi
//StartDrag, DragOver or DragDrop event
//handlers...
//thrown together very quickly!!!
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls, Buttons, StdCtrls;
const
zoomIncrement = 1.1;
origScaleDownFactor = 0.5;
origTopLeftX = 50;
origTopLeftY = 50;
WeeBoxSize = 10;
type
TCursorBitMapRect = record
Left: Integer;
Right: Integer;
Top: Integer;
Bottom: Integer;
//'cursor X to bitMap
//top left X' distance...
cXtoTlX: Integer;
//'cursor Y to bitMap
//top left Y' distance...
cYtoTlY: Integer;
end;
type
TMainForm = class(TForm)
TopPanel: TPanel;
DrawArea: TImage;
procedure DrawAreaMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure DrawAreaMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure DrawAreaMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure FormCreate(Sender: TObject);
procedure FormResize(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure ScaleBitMapToSize(var anyBitMap: Graphics.TBitMap;
newWidth, newHeight: Integer);
function IsClickInsideRect(xPos, yPos: Integer; theRect: TCursorBitMapRect): Boolean;
procedure SetImageExtents;
procedure FillDrawArea;
procedure LoadBitMapFromDisk;
procedure SetOriginalBitMapScale;
procedure DrawWeeBoxAtPoint(thisCanvas: TCanvas; ptToDrawNear: TPoint;
boxColour: TColor);
private
//private declarations
originalBitMap: Graphics.TBitMap;
drawnBitMap: Graphics.TBitMap;
currentScale: Real;
//'cursor bitmap' rectangle...
cBitMapRect: TCursorBitMapRect;
drawAreaBitMap: Graphics.TBitMap;
cursorBitMap: Graphics.TBitMap;
dragInProgress: Boolean;
public
//public declarations
end;
var
MainForm: TMainForm;
implementation
uses TempUnit;
{$R *.DFM}
/////////////////////////////////////////////////////
procedure TMainForm.DrawAreaMouseDown(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var
destRect: TRect;
cornerPt: TPoint;
sourceRect: TRect;
begin
if (IsClickInsideRect(X, Y, cBitMapRect)) then
begin
//make a bitMap out of the area of the TImage where the bitmap
//is currently drawn (identified by the coordinates of cBitMapRect)...
destRect.Left := 0;
destRect.Top := 0;
//get the width and height of the bitmap from cBitMapRect...
destRect.Right := (cBitMapRect.Right - cBitMapRect.Left);
destRect.Bottom := (cBitMapRect.Bottom - cBitMapRect.Top);
cursorBitMap.Width := destRect.Right;
cursorBitMap.Height := destRect.Bottom;
sourceRect.Left := cBitMapRect.Left;
sourceRect.Top := cBitMapRect.Top;
sourceRect.Bottom := cBitMapRect.Bottom;
sourceRect.Right := cBitMapRect.Right;
cursorBitMap.Canvas.CopyRect(destRect, DrawArea.Canvas, sourceRect);
//if you want to verify that you've got a valid cursorBitMap at this
//point you can uncomment out the two lines below and show it on the
//form...
//TempForm.SetDrawAreaPicture(cursorBitMap);
//TempForm.ShowModal;
dragInProgress := True;
//copy the whole of the drawing area to a temporary bitmap...
drawAreaBitMap.Width := DrawArea.Width;
drawAreaBitMap.Height := DrawArea.Height;
drawAreaBitMap.Canvas.Draw(0, 0, DrawArea.Picture.Graphic);
//set up 'selection' of some kind so that we can i) draw
//the 'selection' somehow, but then, ii) later, we can
//make sure we only do a 'drag' if the user moves the mouse
//more than some specified distance...
//first draw wee 'selection boxes' at all four corner points:
//top left, top right, bottom right and bottom left...
cornerPt.x := cBitMapRect.Left;
cornerPt.y := cBitMapRect.Top;
DrawWeeBoxAtPoint(drawAreaBitMap.Canvas, cornerPt, clRed);
cornerPt.x := cBitMapRect.Right;
cornerPt.y := cBitMapRect.Top;
DrawWeeBoxAtPoint(drawAreaBitMap.Canvas, cornerPt, clRed);
cornerPt.x := cBitMapRect.Right;
cornerPt.y := cBitMapRect.Bottom;
DrawWeeBoxAtPoint(drawAreaBitMap.Canvas, cornerPt, clRed);
cornerPt.x := cBitMapRect.Left;
cornerPt.y := cBitMapRect.Bottom;
DrawWeeBoxAtPoint(drawAreaBitMap.Canvas, cornerPt, clRed);
DrawArea.Canvas.Draw(0, 0, drawAreaBitMap);
//store the distances between mouseDown (aka cursor)
//X,Y's and the cBitMapRect top left X,Ys so that we
//can use these values later in MouseMove...
cBitMapRect.cXtoTlX := (X - cBitMapRect.Left);
cBitMapRect.cYtoTlY := (Y - cBitMapRect.Top);
end;
end;
////////////////////////////////////////////////////////////////////////
procedure TMainForm.DrawAreaMouseMove(Sender: TObject; Shift: TShiftState;
X, Y: Integer);
var
cursorXOffset: Integer;
cursorYOffset: Integer;
begin
if (dragInProgress = True) then
begin
DrawArea.Canvas.Draw(0, 0, drawAreaBitMap);
cursorXOffset := cBitMapRect.cXtoTlX;
cursorYOffset := cBitMapRect.cYtoTlY;
DrawArea.Canvas.Draw((X - cursorXOffset), (Y - cursorYOffset),
cursorBitMap);
end;
end;
/////////////////////////////////////////////////////////////////////////
procedure TMainForm.DrawAreaMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
var
dropTlX: Integer;
dropTlY: Integer;
bmpWidth: Integer;
bmpHeight: Integer;
begin
if (dragInProgress = True) then
begin
FillDrawArea;
dropTlX := (X - cBitMapRect.cXtoTlX);
dropTlY := (Y - cBitMapRect.cYtoTlY);
DrawArea.Canvas.Draw(dropTlX, dropTlY, cursorBitMap);
//reset the coordinates of the cBitMapRect such
//that it stores the new 'drop' position...
bmpWidth := (cBitMapRect.Right - cBitMapRect.Left);
bmpHeight := (cBitMapRect.Bottom - cBitMapRect.Top);
cBitMapRect.Left := dropTlX;
cBitMapRect.Right := (dropTlX + bmpWidth);
cBitMapRect.Top := dropTlY;
cBitMapRect.Bottom := (dropTlY + bmpHeight);
dragInProgress := False;
end;
end;
///////////////////////////////////////////////
procedure TMainForm.FormCreate(Sender: TObject);
var
newWidth: Integer;
newHeight: Integer;
begin
currentScale := 1.0;
SetImageExtents;
originalBitMap := Graphics.TBitMap.Create;
drawnBitMap := Graphics.TBitMap.Create;
LoadBitMapFromDisk;
SetOriginalBitMapScale;
DrawArea.Canvas.Draw(origTopLeftX, origTopLeftY, originalBitMap);
KeyPreview := True;
drawAreaBitMap := Graphics.TBitMap.Create;
cursorBitMap := Graphics.TBitMap.Create;
dragInProgress := False;
end;
////////////////////////////////////////////////
procedure TMainForm.FormDestroy(Sender: TObject);
begin
originalBitMap.Free;
drawnBitMap.Free;
cursorBitMap.Free;
drawAreaBitMap.Free;
end;
///////////////////////////////////////////////
procedure TMainForm.FormResize(Sender: TObject);
begin
if (MainForm.Width > Screen.Width) then
MainForm.Width := (Screen.Width - 1);
if (MainForm.Height > Screen.Height) then
MainForm.Height := (Screen.Height - 1);
DrawArea.Width := MainForm.Width;
DrawArea.Height := MainForm.Height;
end;
////////////////////////////////////
procedure TMainForm.SetImageExtents;
{sometimes you find that if you put a TImage on a form and use the TImage
as a 'draw area' it won't resize properly when the form is resized. This
may have to do with only a certain amount of space being reserved for the
image in memory (and the values of TImage.Width/Height not always being
congruent with 'internal bitmap.width/height'). This procedure attempts
to get around these problems as here we expand the image to the screen's
width at the outset so that this much maximum space is always available
whatever resizing of the image we do later...}
begin
DrawArea.Width := Screen.Width;
DrawArea.Height := Screen.Height;
DrawArea.Canvas.MoveTo(0, 0);
DrawArea.Canvas.Pen.Color := clWhite;
DrawArea.Canvas.LineTo(DrawArea.Width, DrawArea.Height);
DrawArea.align := alClient;
end;
/////////////////////////////////
procedure TMainForm.FillDrawArea;
//set the drawing area background
//colour to be white
var
imageRect: TRect;
begin
with DrawArea.Canvas do
begin
Brush.Color := clWhite;
imageRect.Left := 0;
imageRect.Top := 0;
imageRect.Right := Screen.Width;
imageRect.Bottom := Screen.Height;
FillRect(imageRect);
end;
end;
///////////////////////////////////////
procedure TMainForm.LoadBitMapFromDisk;
begin
originalBitMap.LoadFromFile('Arnolfini.bmp');
end;
//////////////////////////////////////////
procedure TMainForm.SetOriginalBitMapScale;
var
newWidth, newHeight: Integer;
begin
newWidth := Round(originalBitMap.Width * origScaleDownFactor);
newHeight := Round(originalBitMap.Height * origScaleDownFactor);
ScaleBitMapToSize(originalBitMap, newWidth, newHeight);
cBitMapRect.Left := origTopLeftX;
cBitMapRect.Top := origTopLeftY;
cBitMapRect.Right := (cBitMapRect.Left + newWidth);
cBitMapRect.Bottom := (cBitMapRect.Top + newHeight);
end;
/////////////////////////////////////////////////////////////////////
procedure TMainForm.ScaleBitMapToSize(var anyBitMap: Graphics.TBitMap;
newWidth, newHeight: Integer);
//scale the passed bitmap according to the width and height dimensions
//passed in...
var
tempBitMap: TBitMap;
newRect: TRect;
begin
tempBitMap := TBitMap.Create;
newRect.Left := 0;
newRect.Right := newWidth;
newRect.Top := 0;
newRect.Bottom := newHeight;
tempBitMap.Width := newWidth;
tempBitMap.Height := newHeight;
tempBitMap.Canvas.StretchDraw(newRect, anyBitMap);
anyBitMap.Width := tempBitMap.Width;
anyBitMap.Height := tempBitMap.Height;
anyBitMap.Assign(tempBitMap);
tempBitMap.Free;
end;
////////////////////////////////////////////////////////////////////////////////////////
function TMainForm.IsClickInsideRect(xPos, yPos: Integer; theRect: TCursorBitMapRect): Boolean;
//reusable function to check if the passed in coordinate identified by X and Y is
//within the rectangle passed in: return True if so; return False if not...
var
inXRange: Boolean;
inYRange: Boolean;
begin
inXRange := False;
inYRange := False;
if ((xPos > cBitMapRect.Left) and (xPos < cBitMapRect.Right)) then
begin
inXRange := True;
end;
if ((yPos > cBitMapRect.Top) and (yPos < cBitMapRect.Bottom)) then
begin
inYRange := True;
end;
if ((inXRange = True) and (inYRange = True)) then
Result := True
else Result := False;
end;
///////////////////////////////////////////////////////////////////////////////
procedure TMainForm.DrawWeeBoxAtPoint(thisCanvas: TCanvas; ptToDrawNear: TPoint;
boxColour: TColor);
//draw a tiny square in the passed in colour that is WeeBoxSize pixels above,
//right, below and left of the point passed in. Call this proc to draw boxes
//at the corners of selected entities drawn on a TImage, for instance...
var
scrOriginX: Integer;
scrOriginY: Integer;
begin
thisCanvas.Pen.Width := 1;
thisCanvas.Pen.Color := boxColour;
thisCanvas.MoveTo(Round(ptToDrawNear.x - WeeBoxSize),
Round(ptToDrawNear.y - WeeBoxSize));
thisCanvas.LineTo(Round(ptToDrawNear.x + WeeBoxSize),
Round(ptToDrawNear.y - WeeBoxSize));
thisCanvas.LineTo(Round(ptToDrawNear.x + WeeBoxSize),
Round(ptToDrawNear.y + WeeBoxSize));
thisCanvas.LineTo(Round(ptToDrawNear.x - WeeBoxSize),
Round(ptToDrawNear.y + WeeBoxSize));
thisCanvas.LineTo(Round(ptToDrawNear.x - WeeBoxSize),
Round(ptToDrawNear.y - WeeBoxSize));
end;
end.
]]>