Want to protect your cyber security and still get fast solutions? Ask a secure question today.Go Premium

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 487
  • Last Modified:

Dragging an item

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
JackKuti
Asked:
JackKuti
  • 3
  • 3
1 Solution
 
atul_parmarCommented:
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
 
JackKutiAuthor Commented:
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
 
Russell LibbySoftware Engineer, Advisory Commented:
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
VIDEO: THE CONCERTO CLOUD FOR HEALTHCARE

Modern healthcare requires a modern cloud. View this brief video to understand how the Concerto Cloud for Healthcare can help your organization.

 
JackKutiAuthor Commented:
Thanks for your code. And don´t you know how to remove the crossed ring being displayed while dragging?
0
 
Russell LibbySoftware Engineer, Advisory Commented:
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
 
Russell LibbySoftware Engineer, Advisory Commented:

////////////////////////////////////////////////////////////////////////////////
//   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
 
JackKutiAuthor Commented:
Trying if it looks better without the ring, if it won´t  the ring will be returned. Many thanks to you!
0

Featured Post

Independent Software Vendors: We Want Your Opinion

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

  • 3
  • 3
Tackle projects and never again get stuck behind a technical roadblock.
Join Now