Solved

Dragging an item

Posted on 2006-06-16
7
480 Views
Last Modified: 2013-12-03
I want to click item in the ListBox and then drag the item somewhere on other component (eg. other ListBox), but I want the item still to appear under the cursor while draging. To be more exact, I want to drag name of font from the font list and drop it to some text in other component and by this to change font of the text.  How can be this effect achieved?
0
Comment
Question by:JackKuti
  • 3
  • 3
7 Comments
 
LVL 10

Expert Comment

by:atul_parmar
ID: 16921462
e.g. ListBox1 contains the font names then
Set the following
  1. ListBox1.Drag Mode = dgAutomatic;
  2. ListBox1.Tag := -1; // this will track the item to drag

in the OnMouseDown of ListBox1 write the following line

  ListBox1.Tag := ListBox1.ItemAtPos(Point(X, Y), True);

in the OnDragOver event of other control put the following line

Accept := ListBox1.Tag > -1;

in the OnDragDrop event of other control put the following code

  if ListBox1.Tag > -1 then
  begin
   Edit1.Font.Name := ListBox1.Items.Strings[ListBox1.Tag]; // assuming that the item is being dragged to edit box
   ListBox1.Tag := -1; // reset the dragged item
  end;
0
 

Author Comment

by:JackKuti
ID: 16921838
Thanks, font are changed perfectly, but still, I´d like to achieve the effect of appearing of font name under the cursor while draging it from ListBox untill it is dropped down. This is not necessary for the application to work but its nice.  
0
 
LVL 26

Accepted Solution

by:
Russell Libby earned 250 total points
ID: 16923312
Example of what you are asking for. Source first, dfm follows.

Regards,
Russell


--- unit1.pas ---

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ImgList;

////////////////////////////////////////////////////////////////////////////////
//   Control accessor
////////////////////////////////////////////////////////////////////////////////
type
  TControlAccess    =  class(TControl);

////////////////////////////////////////////////////////////////////////////////
//   TTextDrag
////////////////////////////////////////////////////////////////////////////////
type
  TTextDrag         =  class(TDragObject)
  private
     // Private declarations
     FDragImage:    TDragImageList;
     FText:         String;
  protected
     // Protected declarations
     function       GetDragImages: TDragImageList; override;
  public
     // Public declarations
     constructor    Create;
     destructor     Destroy; override;
     procedure      UpdateDragImage(Font: TFont; Text: String);
     property       Text: String read FText;
  end;

type
  TForm1            =  class(TForm)
     Memo1:         TMemo;
     ListBox1:      TListBox;
     procedure      FormCreate(Sender: TObject);
     procedure      FormDestroy(Sender: TObject);
     procedure      ListBox1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
     procedure      ListBox1StartDrag(Sender: TObject; var DragObject: TDragObject);
     procedure      Memo1DragOver(Sender, Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean);
     procedure      Memo1DragDrop(Sender, Source: TObject; X, Y: Integer);
  private
     //  Private declarations
     FDragObject:   TTextDrag;
  public
     // Public declarations
  end;

var
  Form1: TForm1;

implementation
{$R *.DFM}

function TTextDrag.GetDragImages: TDragImageList;
begin

  // Return the drag image list
  result:=FDragImage;

end;

procedure TTextDrag.UpdateDragImage(Font: TFont; Text: String);
var  bmpDrag:       TBitmap;
     ptText:        TSize;
begin

  // Free existing drag image list
  if Assigned(FDragImage) then FreeAndNil(FDragImage);

  // Create the bitmap to draw on
  bmpDrag:=TBitmap.Create;

  // Resource protection
  try
     // Update internal text
     FText:=Text;
     // Set canvas font
     bmpDrag.Canvas.Font.Assign(Font);
     // Get text width and height
     ptText:=bmpDrag.Canvas.TextExtent(Text);
     // Add single space around the top/bottom, and 10 to right side side
     Inc(ptText.cx, 22);
     Inc(ptText.cy, 2);
     // Set bitmap size
     bmpDrag.Width:=ptText.cx;
     bmpDrag.Height:=ptText.cy;
     // Draw the text on the bitmap canvas
     bmpDrag.Canvas.TextOut(20, 1, Text);
     // Create the drag image list
     FDragImage:=TDragImageList.CreateSize(ptText.cx, ptText.cy);
     // Add bitmap to the image list
     FDragImage.AddMasked(bmpDrag, bmpDrag.Canvas.Pixels[0, 0]);
     // Set drag image
     FDragImage.SetDragImage(0, 0, 0);
  finally
     // Free the bitmap
     bmpDrag.Free;
  end;

end;

constructor TTextDrag.Create;
begin

  // Perform inherited
  inherited Create;

  // Set default text
  SetLength(FText, 0);

  // Create drag image list with text
  FDragImage:=nil;

end;

destructor TTextDrag.Destroy;
begin

  // Resource protection
  try
     // Free drag image list
     FDragImage.Free;
  finally
     // Perform inherited
     inherited Destroy;
  end;

end;

procedure TForm1.FormCreate(Sender: TObject);
var  dwIndex:       Integer;
begin

  // Create drag object
  FDragObject:=TTextDrag.Create;

  // Update form's control style
  Self.ControlStyle:=Self.ControlStyle + [csDisplayDragImage];

  // Update control style for all controls
  for dwIndex:=0 to Pred(ControlCount) do Controls[dwIndex].ControlStyle:=Controls[dwIndex].ControlStyle + [csDisplayDragImage];

  // Lock listbox
  ListBox1.Items.BeginUpdate;

  // Resource protection
  try
     // Clear list
     ListBox1.Items.Clear;
     // Add font names to list
     for dwIndex:=0 to Pred(Screen.Fonts.Count) do ListBox1.Items.Add(Screen.Fonts[dwIndex]);
  finally
     // Unlock listbox
     ListBox1.Items.EndUpdate;
  end;

end;

procedure TForm1.FormDestroy(Sender: TObject);
begin

  // Free the drag object
  FDragObject.Free;

end;

procedure TForm1.ListBox1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin

  // Set drag if item is selected
  if (ListBox1.ItemIndex >= 0) then ListBox1.BeginDrag(False, 5);

end;

procedure TForm1.ListBox1StartDrag(Sender: TObject; var DragObject: TDragObject);
var  fntDrag:    TFont;
begin

  // Create font to duplicate for dragging
  fntDrag:=TFont.Create;

  // Resource protection
  try
     // Update from control first
     fntDrag.Assign(ListBox1.Font);
     // Update the font name
     fntDrag.Name:=ListBox1.Items[ListBox1.ItemIndex];
     // Update the drag object
     FDragObject.UpdateDragImage(fntDrag, fntDrag.Name);
     // Set the drag object to use
     DragObject:=FDragObject;
  finally
     // Free the temp font
     fntDrag.Free;
  end;

end;

procedure TForm1.Memo1DragOver(Sender, Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean);
begin

  // Accept the drag
  Accept:=True;
 
end;

procedure TForm1.Memo1DragDrop(Sender, Source: TObject; X, Y: Integer);
begin

  // Check drop source
  if (Source is TTextDrag) then Memo1.Font.Name:=TTextDrag(Source).Text;

end;

end.

--- unit1.dfm ---

object Form1: TForm1
  Left = 359
  Top = 278
  Width = 371
  Height = 358
  Caption = 'Form1'
  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 Memo1: TMemo
    Left = 164
    Top = 12
    Width = 185
    Height = 297
    Lines.Strings = (
      'Test of custom drag image handling')
    TabOrder = 0
    OnDragDrop = Memo1DragDrop
    OnDragOver = Memo1DragOver
  end
  object ListBox1: TListBox
    Left = 8
    Top = 12
    Width = 149
    Height = 297
    ItemHeight = 13
    TabOrder = 1
    OnMouseDown = ListBox1MouseDown
    OnStartDrag = ListBox1StartDrag
  end
end
0
Free Tool: Path Explorer

An intuitive utility to help find the CSS path to UI elements on a webpage. These paths are used frequently in a variety of front-end development and QA automation tasks.

One of a set of tools we're offering as a way of saying thank you for being a part of the community.

 

Author Comment

by:JackKuti
ID: 16923676
Thanks for your code. And don´t you know how to remove the crossed ring being displayed while dragging?
0
 
LVL 26

Expert Comment

by:Russell Libby
ID: 16923740
Are you sure you want to do that? Its the only UI cue to the user when a  drop operation cannot be performed.

Russell
0
 
LVL 26

Expert Comment

by:Russell Libby
ID: 16923776

////////////////////////////////////////////////////////////////////////////////
//   TTextDrag
////////////////////////////////////////////////////////////////////////////////
type
  TTextDrag         =  class(TDragObject)
  private
     // Private declarations
     FDragImage:    TDragImageList;
     FText:         String;
  protected
     // Protected declarations
     function       GetDragCursor(Accepted: Boolean; X, Y: Integer): TCursor; override; // ADD
     function       GetDragImages: TDragImageList; override;
  public
     // Public declarations
     constructor    Create;
     destructor     Destroy; override;
     procedure      UpdateDragImage(Font: TFont; Text: String);
     property       Text: String read FText;
  end;

 etc....

implementation
{$R *.DFM}

function TTextDrag.GetDragCursor(Accepted: Boolean; X, Y: Integer): TCursor;
begin

  // Perform inherited
  result:=inherited GetDragCursor(Accepted, X, Y);

  // Check accepted = false. You can also remove this check and always return zero
  // which will make it use the default cursor
  if not(Accepted) then result:=0;

end;

0
 

Author Comment

by:JackKuti
ID: 16926020
Trying if it looks better without the ring, if it won´t  the ring will be returned. Many thanks to you!
0

Featured Post

Free Tool: Site Down Detector

Helpful to verify reports of your own downtime, or to double check a downed website you are trying to access.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Suggested Solutions

A lot of questions regard threads in Delphi.   One of the more specific questions is how to show progress of the thread.   Updating a progressbar from inside a thread is a mistake. A solution to this would be to send a synchronized message to the…
The uses clause is one of those things that just tends to grow and grow. Most of the time this is in the main form, as it's from this form that all others are called. If you have a big application (including many forms), the uses clause in the in…
Excel styles will make formatting consistent and let you apply and change formatting faster. In this tutorial, you'll learn how to use Excel's built-in styles, how to modify styles, and how to create your own. You'll also learn how to use your custo…

828 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question