Sample Application: CursorTest.dpr

Project source
Form source (Pascal)
Form source (DFM)

Design-time form image
Project source: CursorTest.dpr 

program CursorTest;

uses
  Forms,
  fmCursorTest in 'fmCursorTest.pas' {Form1};

{$R *.RES}

begin
  Application.Initialize;
  Application.CreateForm(TForm1, Form1);
  Application.Run;
end.
Back to top
Form source: fnCursorTest.pas 

unit fmCursorTest;

{ UnitOOPS OLE Drag and Drop Components - Example
  for using custom cursors for feedback during a drag operation.

 Last modified:  09/29/99}

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  FileCtrl, StdCtrls, uoole, ExtCtrls;

type
  TForm1 = class(TForm)
    UOTextSource1: TUOTextSource;
    UOTextTarget1: TUOTextTarget;
    Panel1: TPanel;
    Panel2: TPanel;
    DriveComboBox1: TDriveComboBox;
    DirectoryListBox1: TDirectoryListBox;
    FileListBox1: TFileListBox;
    Label1: TLabel;
    procedure UOTextSource1GiveFeedback(Sender: TObject;
      effect: TDropEffect; var defCursors: Boolean);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure FileListBox1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
  private
    { Private declarations }

    dragIcons: array[TDropEffect] of TIcon;
    procedure InitializeDragCursors(isFile: boolean);
    procedure FreeDragCursors;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

uses
  ShellAPI, uoUtil;

{$R *.DFM}
{$R olecursors.res}

const
  crOLENo = 1;
  crOLECopy = 2;
  crOLEMove = 3;
  crOLELink = 4;


procedure TForm1.UOTextSource1GiveFeedback(Sender: TObject;
  effect: TDropEffect; var defCursors: Boolean);
// Give feedback by overriding the standard cursors.
// This is all you need to change the cursors - you just use SetCursor (a WinAPI
// call) with some cursor handle.
// In this sample, we get fancier than that - we dynamically draw a new set
// of drag cursors at the start of each drag, to incorporate the file icon
// and file name being dragged.
begin
  defCursors := false;

  SetCursor(DragIcons[effect].Handle);
end;

procedure TForm1.FreeDragCursors;
// Clean up the icons that are being used as drag cursors
var
  aDe: TDropEffect;
begin
  for aDe := low(TDropEffect) to pred(high(TDropEffect)) do
  begin
    if assigned(dragIcons[aDe]) then
    begin
      dragIcons[aDe].Free;
      dragIcons[aDe] := nil;
    end;
  end;
end;

procedure TForm1.InitializeDragCursors(isFile: boolean);
// Each time we start a drag, we'll call this function.  It constructs
// a set of icons that we use as the drag cursors for each type of operation
// (no drop, copy, move, link).  In situations like this, Windows treats
// cursor handles and icon handles the same.
// Here, we're generating the cursors dynamically.  We could, of course, use
// custom cursors that didn't change at all over the course of the application,
// in which case we'd just load them once from the resources.
// isFile is true if we're dragging from the file list, false if we're dragging
// from the directory list.
const
  iHeight = 75;
  iWidth = 800;
var
  aBMP: TBitmap;
  aDe: TDropEffect;
  ilDrag: TImageList;
  aShFI: TShFileInfo;
  dragString: string;
begin
  // For each operation, we'll just use the filename as the text
  if isFile then
    dragString := Filelistbox1.Filename
  else
    dragString := DirectoryListBox1.Directory;

  // Get the small icon for the file being dragged
  fillChar(aShfi, sizeOf(aShfi), 0);
  SHGetFileInfo(PChar(dragString), 0, aShFI, sizeOf(aShFI),
    SHGFI_ICON or SHGFI_SMALLICON);

  // Clear out the icons
  FreeDragCursors;
  // Create one icon for each operation
  for aDe := low(TDropEffect) to pred(high(TDropEffect)) do
  begin
    dragIcons[aDe] := TIcon.Create;
  end;

  // Make an image list.  We use this since it has methods that allow us to stuff
  // a bitmap and mask color in, and get an icon out.
  ilDrag := TImageList.Create(nil);
  // Make the size of each individual image large to accomodate long text.
  // We're only using half, since the hotspot is in the middle.
  ilDrag.Height := iHeight;
  ilDrag.Width := iWidth;
  try
    // Make the temporary bitmap onto whose handle we'll draw the content that
    // will become the cursors.
    aBMP := TBitmap.Create;
    try
      aBMP.width := iWidth;
      aBMP.height := iHeight;
      with aBMP.Canvas, aBMP do
      begin
        // Loop over all drop effects (except scroll)
        for aDe := low(TDropEffect) to pred(high(TDropEffect)) do
        begin
          // Hot-spot will be in the center of the icon/cursor

          // Choose font settings
          // Use text in red for "no drop" case
          if aDe = deNone then
            Font.Color := clRed
          else
            Font.Color := clWindowText;

          // Fill the background with solid olive, the color we use as mask
          // This effectively "clears" the background, since the mask color
          // will be gone when we turn this into a cursor.
          Brush.Color := clOlive;
          Brush.Style := bsSolid;
          FillRect(Rect(0, 0, width, height));

          // Draw the appropriate cursor.
          // Here, we've loaded some custom
          // cursors from olecursors.res (just the standard OLE cursors, taken
          // from OLE32.DLL using Resource Workshop).  See the FormCreate method
          // above for more information.
          DrawIcon(aBMP.Canvas.Handle, width div 2, height div 2,
            Screen.Cursors[crOLENo + ord(aDe)]);

          // Draw the small file icon
          // Use DrawIconEx rather than DrawIcon, since the latter appears to
          // insist on drawing even a small icon by stretching to the default
          // icon metrics.
          DrawIconEx(aBMP.Canvas.Handle, width div 2 + 16 ,
            (height - GetSystemMetrics(SM_CYSMICON)) div 2,
            aShfi.hIcon, 0, 0, 0, 0, DI_NORMAL);

          // Draw the text string, on a clear background
          // Here we just draw the file name.  We align it to the
          // icon, already drawn.
          Brush.Style := bsClear;
          TextOut(width div 2 + 20 + GetSystemMetrics(SM_CXSMICON),
            (height - abs(Font.Height)) div 2, dragString);

          // Here's the action part of the procedure.  Add the image to the
          // image list using clOlive as the mask, then extract it as an icon
          // into the appropriate element of dragIcons[].
          ilDrag.AddMasked(aBMP, clOlive);
          ilDrag.GetIcon(ilDrag.Count-1, dragIcons[aDe]);
        end;
      end;
    finally
      aBMP.Free;
    end;
  finally
    ilDrag.Free;
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  // Load the custom cursors defined on olecursurs.res.
  // They're actually just the standard OLE cursors from OLE32.DLL
  Screen.Cursors[crOLECopy] := LoadCursor(HInstance, 'CURCOPY');
  Screen.Cursors[crOLEMove] := LoadCursor(HInstance, 'CURMOVE');
  Screen.Cursors[crOLELink] := LoadCursor(HInstance, 'CURLINK');
  Screen.Cursors[crOLENo] := LoadCursor(HInstance, 'CURNO');

  // Trickery.  If the form isn't itself an OLE drop target, we'll get the
  // standard "no drop" cursor, rather than our custom one.  To get our custom
  // "no drop" cursor, we set up a dummy text target with the form as its
  // AcceptorControl, but that accepts no formats!
  UOTextTarget1.AcceptTextFormats := [];
  UOTextTarget1.AcceptorControl := Self;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  // Clean up.
  FreeDragCursors;
end;

procedure TForm1.FileListBox1MouseDown(Sender: TObject;
  Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
// This is shared by FileListBox1 and DirectoryListBox1.
var
  aSL: TStringList;
begin
  // Probably the best way to start a drag.  No cursor changes happen
  // until you leave the drag rect.
  if DragDetect(Handle, ClientToScreen(POINT(X, Y))) then
  begin
    // Set up the drag cursors based on the current selection
    InitializeDragCursors(Sender = FileListBox1);
    // Do the drag
    with UOTextSource1 do
    begin
      Text := '';  // Don't pass any text
      aSL := TStringList.Create;
      if (Sender = FileListBox1) then
        aSL.add(FileListBox1.FileName)
      else
        aSL.add(DirectoryListBox1.Directory);
      try
        CustomFormatData.Clear;
        // Pass file copy, move, link information
        CustomFormatData.AddFormat(IntToStr(CF_HDROP),
          uoHDropFromFileList('', aSL));
        CustomFormatData.AddFormat('Shell IDList Array',
          uoShellIDListFromFileList('', aSL));
      finally
        aSL.Free;
      end;
      Execute;  // Start the drag operation
    end;
  end;
end;

end.
Back to top
Form source: fmCursorTest.dfm 

object Form1: TForm1
  Left = 312
  Top = 196
  BorderStyle = bsDialog
  Caption = 'Custom Drag Cursor Test'
  ClientHeight = 233
  ClientWidth = 321
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = False
  OnCreate = FormCreate
  OnDestroy = FormDestroy
  PixelsPerInch = 96
  TextHeight = 13
  object Panel1: TPanel
    Left = 0
    Top = 0
    Width = 321
    Height = 65
    Align = alTop
    BevelOuter = bvNone
    BorderWidth = 5
    TabOrder = 0
    object Label1: TLabel
      Left = 5
      Top = 5
      Width = 311
      Height = 55
      Align = alClient
      Caption = 
        'Drag from either the directory list or the file list to any appl' +
        'ication (e.g., Explorer) that accepts file drops.  You can drag ' +
        'shortcuts, copy, or move by holding down the appropriate keys (C' +
        'trl, Shift, or both together).  '
      WordWrap = True
    end
  end
  object Panel2: TPanel
    Left = 0
    Top = 65
    Width = 321
    Height = 168
    Align = alClient
    BevelOuter = bvNone
    TabOrder = 1
    object DriveComboBox1: TDriveComboBox
      Left = 4
      Top = 3
      Width = 145
      Height = 19
      DirList = DirectoryListBox1
      TabOrder = 0
    end
    object DirectoryListBox1: TDirectoryListBox
      Left = 4
      Top = 27
      Width = 145
      Height = 136
      FileList = FileListBox1
      ItemHeight = 16
      TabOrder = 1
      OnMouseDown = FileListBox1MouseDown
    end
    object FileListBox1: TFileListBox
      Left = 154
      Top = 3
      Width = 161
      Height = 160
      ItemHeight = 13
      TabOrder = 2
      OnMouseDown = FileListBox1MouseDown
    end
  end
  object UOTextSource1: TUOTextSource
    OnGiveFeedback = UOTextSource1GiveFeedback
    DropEffects = [deCopy, deMove, deLink]
    Left = 96
    Top = 177
  end
  object UOTextTarget1: TUOTextTarget
    AcceptTextFormats = []
    Left = 32
    Top = 161
  end
end
Back to top

Back to the examples page