Вопросы и ответы - Delphi - VCL, написание и доработка компонентов

CheckBox в DBGrid

Код

procedure DrawGridCheckBox(Canvas: TCanvas; Rect: TRect; Checked: boolean);

var

DrawFlags: Integer;

begin

Canvas.TextRect(Rect, Rect.Left + 1, Rect.Top + 1, ' ');

DrawFrameControl(Canvas.Handle, Rect, DFC_BUTTON, DFCS_BUTTONPUSH or DFCS_ADJUSTRECT);

DrawFlags := DFCS_BUTTONCHECK or DFCS_ADJUSTRECT;// DFCS_BUTTONCHECK

if Checked then

DrawFlags := DrawFlags or DFCS_CHECKED;

DrawFrameControl(Canvas.Handle, Rect, DFC_BUTTON, DrawFlags);

end;

На событие OnDrawColumnCell повесьте вызов процедуры DrawGridCheckBox():

Код

procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject; const Rect: TRect;

DataCol: Integer; Column: TColumn; State: TGridDrawState);

begin

if Column.FieldName = 'WEIGHT' then // Модифицируйте под себя

if Column.Field.AsInteger > 10 then

DrawGridCheckBox(DBGrid1.Canvas, Rect, true)

else

DrawGridCheckBox(DBGrid1.Canvas, Rect, false)

end;

Кроме этого, для скрытия текста в ячейках с CheckBox-ом от отображения значения при вводе с клавиатуры определите реакцию на событие OnColumnEnter:

Код

procedure TfrmMain.DBGrid1ColEnter(Sender: TObject);

begin

with TDBGrid(Sender) do

if SelectedField.FieldName = 'Weight' then // Модифицируйте под себя

Options := Options - [dgEditing]

else

Options := Options + [dgEditing]

end;

Drag and Drop - как использовать ItemAtPos для получения элемента DirListBox

Просто сохраните результат функции ItematPos в переменной формы, и затем используйте эту переменную в обработчике ListBoxDragDrop. Пример:

Код

FDragItem := ItematPos(X, Y, True);

if FDragItem >= 0 then

BeginDrag(false);

...

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

begin

if Source is TDirectoryListBox then

ListBox.Items.Add(TDirectoryListBox(Source).GetItemPath(FDragItem));

end;

Drag and Drop TImage

Вот рабочий пример. Расположите на форме панель побольше, скопируйте и измените приведенный код так, чтобы изображение загружалось из ВАШЕГО каталога Delphi.

Код

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

begin

with Source as TImage do

begin

Left := X;

Top := Y;

end;

end;

procedure TForm1.Panel1DragOver(Sender, Source: TObject; X, Y: Integer;

State: TDragState; var Accept: Boolean);

begin

Accept := Source is TImage;

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

with TImage.Create(Self) do

begin

Parent := Panel1;

AutoSize := True;

Picture.LoadFromFile('D:DELPHIIMAGESCHIP.BMP');

DragMode := dmAutomatic;

OnDragOver := Panel1DragOver;

OnDragDrop := Panel1DragDrop;

end;

end;

Drag and Drop в TOutline

Проблема заключается в том, что прежде, чем windows сможет обработать сообщение WM_MouseUp, курсор мыши передвинется дальше. Вот решение этой головоломки:

Разрешите Windows как можно скорее обработатывать события мыши:

Код

OnMouseDown:

BeginDrag(False);

while ... do

begin

Application.ProccessMessages; { это позволяет Windows обработать }

{ все сообщения за один шаг }

end;

Обратите пристальное внимание при создании цикла, если вы используете цикл типа 'while', то вы должны предусмотреть возможность выхода из него, например, при закрытии приложения, или других действий пользователя, требующих экстренного выхода из тела цикла.

Drag and Drop для двух компонентов TOutline

Код

unit Unit1;

interface

uses

SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,

Forms, Dialogs, Grids, Outline;

type

TForm1 = class(TForm)

Outline1: TOutline;

Outline2: TOutline;

procedure OutlineDragDrop(Sender, Source: TObject; X, Y: Integer);

procedure OutlineMouseDown(Sender: TObject; Button: TMouseButton;

Shift: TShiftState; X, Y: Integer);

procedure OutlineDragOver(Sender, Source: TObject; X, Y: Integer;

State: TDragState; var Accept: Boolean);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

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

begin

with Sender as TOutline do

begin

AddChild(GetItem(x, y),

TOutline(Source).Items[TOutline(Source).SelectedItem].Text);

end;

end;

procedure TForm1.OutlineMouseDown(Sender: TObject; Button: TMouseButton;

Shift: TShiftState; X, Y: Integer);

begin

if Button = mbLeft then

with Sender as TOutline do

begin

if GetItem(x, y) >= 0 then

BeginDrag(False);

end;

end;

procedure TForm1.OutlineDragOver(Sender, Source: TObject; X, Y: Integer;

State: TDragState; var Accept: Boolean);

begin

if (Source is TOutline) and (TOutline(Source).GetItem(x, y) <>

TOutline(Source).SelectedItem) then

Accept := True

else

Accept := False;

end;

end.

Drag and Drop из RichEdit

Код

var

Form1: TForm1;

richcopy: string