Полный исходный текст
{——————————————————————————————————————————————————————} { Применение общих обработчиков событий } { (демонстрационная программа) } { SHARMAIN.PAS : Главный модуль } { Автор: Эйс Брейкпойнт, N.T.P. } { При содействии Дона Тейлора } { } { Программа демонстрирует применение общих } { обработчиков событий в пределах одного приложения } { на примере операции перетаскивания. } { } { Написано для *High Performance Delphi 3 Programming* } { Copyright (c) 1997 The Coriolis Group, Inc. } { Дата последней редакции 30/4/97 } {——————————————————————————————————————————————————————} unit SharMain; interface uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, Grids, StdCtrls, ExtCtrls, ComCtrls; type TShareEventDemoForm = class(TForm) EditBox: TEdit; Label1: TLabel; QuitBtn: TButton; Panel1: TPanel; PageControl: TPageControl; MorningSheet: TTabSheet; AfternoonSheet: TTabSheet; EveningSheet: TTabSheet; MorningGrid: TStringGrid; AfternoonGrid: TStringGrid; EveningGrid: TStringGrid; procedure FormCreate(Sender: TObject);
procedure QuitBtnClick(Sender: TObject);
procedure EditBoxMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
procedure GridMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
procedure GridDragOver(Sender, Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean);
procedure GridDragDrop(Sender, Source : TObject; X, Y : Integer);
procedure PageControlDragOver(Sender, Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean);
procedure PageControlDragDrop(Sender, Source: TObject; X, Y: Integer);
private CopyDrag : Boolean; function ManualTabsSet : Boolean; function CurrentGrid : TStringGrid; function TabGrid(X : Integer) : TStringGrid; procedure SetTabSizes; procedure DropEditString(AGrid : TStringGrid);
procedure DropGridString(TargetGrid : TStringGrid);
public { Public declarations } end; var ShareEventDemoForm: TShareEventDemoForm; implementation {$R *.DFM} { Возвращает длину (в пикселях) отображаемой строки по логическому номеру окна, в котором она выводится, и логическому номеру шрифта. } function StringWidth(WinHnd : HWND; FntHnd : HWND; Text : String) : Integer; var DCHnd : HWND; StrSize : TSize; TextArr : array[0..127] of char; begin Result := -1; DCHnd := GetDC(WinHnd);
if GetMapMode(DCHnd) = MM_TEXT then begin SelectObject(DCHnd, FntHnd);
StrPCopy(TextArr, Text);
if GetTextExtentPoint32(DCHnd, @TextArr, Length(Text), StrSize) then Result := StrSize.Cx end; ReleaseDC(WinHnd, DCHnd);
end; { Возвращает высоту шрифта (в пикселях) по логическому номеру окна, в котором он выводится, и логическому номеру шрифта. Высота должна учитывать строчные и подстрочные элементы, а также внутренний интервал. } function FontHeight(WinHnd : HWND; FntHnd : HWND) : Integer; var DCHnd : HWND; TextMex : TTextMetric; begin Result := -1; DCHnd := GetDC(WinHnd);
if GetMapMode(DCHnd) = MM_TEXT then begin SelectObject(DCHnd, FntHnd);
GetTextMetrics(DCHnd, TextMex);
Result := TextMex.tmHeight; end; ReleaseDC(WinHnd, DCHnd);
end; procedure TShareEventDemoForm.FormCreate(Sender: TObject);
begin PageControl.ActivePage := MorningSheet; SetTabSizes; CopyDrag := False; end; procedure TShareEventDemoForm.QuitBtnClick(Sender: TObject);
begin Close; end; procedure TShareEventDemoForm.EditBoxMouseDown (Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin { Перед тем как начинать перетаскивание, необходимо убедиться в том, что нажата левая кнопка мыши, в текстовом поле присутствует текст и щелчок был не двойным. } if (Button = mbLeft) and (EditBox.Text <>
'') and not (ssDouble in Shift) then TEdit(Sender).BeginDrag(False);
end; { Общий обработчик для события OnMouseDown всех сеток. } procedure TShareEventDemoForm.GridMouseDown (Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var TheGrid : TStringGrid; begin { Инициируем перетаскивание из текущей выбранной сетки. Если нажата клавиша Ctrl, устанавливаем флаг CopyDrag. Перед тем как начинать перетаскивание, убедимся в том, что нажата левая кнопка мыши, в выделенной строке сетки присутствует текст щелчок был не двойным. } TheGrid := CurrentGrid; CopyDrag := ssCtrl in Shift; if (Button = mbLeft) and (TheGrid.Cells[0, TheGrid.Row] <>
'') and not (ssDouble in Shift) then TStringGrid(Sender).BeginDrag(False);
end; { Общий обработчик для события OnDragOver всех сеток. } procedure TShareEventDemoForm.GridDragOver(Sender, Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean);
begin { Принимается все, что угодно, но только из текстового поля. } Accept := Source is TEdit; end; { Общий обработчик для события OnDragDrop всех сеток. } procedure TShareEventDemoForm.GridDragDrop (Sender, Source : TObject; X, Y : Integer);
begin { Сбрасываем перетаскиваемый объект на текущую выбранную решетку. } DropEditString(CurrentGrid);
end; procedure TShareEventDemoForm.PageControlDragOver (Sender, Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean);
begin { Сбрасывание на корешке вкладки принимается лишь в том случае, если перетаскиваемый объект происходит из текстового поля или сетки — при условии, что корешок относится не к той сетке, из которой начато перетаскивание. В любом случае размеры корешков должны быть установлены вручную. } Accept := ManualTabsSet and ( (Source is TEdit) or ((Source is TStringGrid) and (CurrentGrid <>
TabGrid(X))) );
end; procedure TShareEventDemoForm.PageControlDragDrop (Sender, Source: TObject; X, Y: Integer);
begin { Получаем строку из нужного источника и сбрасываем ее на сетку, связанную со вкладкой в позиции X. } if (Source is TEdit) then DropEditString (TabGrid(X));
if (Source is TStringGrid) then DropGridString (TabGrid(X));
end; { Возвращает True лишь в том случае, если и высота, и ширина вкладки были заданы вручную. } function TShareEventDemoForm.ManualTabsSet : Boolean; begin Result := (PageControl.TabHeight >
0) and (PageControl.TabWidth >
0);
end; { Возвращает указатель на сетку, находящуюся на текущей вкладке. } function TShareEventDemoForm.CurrentGrid : TStringGrid; begin Result := nil; if PageControl.ActivePage = MorningSheet then Result := MorningGrid else if PageControl.ActivePage = AfternoonSheet then Result := AfternoonGrid else if PageControl.ActivePage = EveningSheet then Result := EveningGrid; end; { Возвращает указатель на сетку, связанную со вкладкой в позиции X. } function TShareEventDemoForm.TabGrid(X : Integer) : TStringGrid; var Idx : Integer; begin Result := nil; with PageControl do begin Idx := X div TabWidth; case Idx of 0 : Result := MorningGrid; 1 : Result := AfternoonGrid; 2 : Result := EveningGrid; end; { case } end; { with } end; { ?егулирует высоту и ширину корешков, следя за тем, чтобы все корешки имели одинаковые размеры. } procedure TShareEventDemoForm.SetTabSizes; var i : Integer; Len : Integer; MaxWidth : Integer; s : String; begin with PageControl do begin if TabWidth >
0 then begin MaxWidth := -1; for i := 0 to PageCount - 1 do begin s := Pages[i].Caption; Len := StringWidth(Handle, Font.Handle, s);
if Len >
MaxWidth then MaxWidth := Len; end; if MaxWidth >
0 then TabWidth := MaxWidth + 10; end; if TabHeight >
0 then PageControl.TabHeight := FontHeight (Handle, Font.Handle) + 5; end; { with } end; { Вспомогательная процедура для сброса строки из текстового поля на указанную сетку. Также очищает содержимое текстового поля. } procedure TShareEventDemoForm.DropEditString (AGrid : TStringGrid);
begin if AGrid <>
nil then with AGrid do begin Cells[0, RowCount - 1] := EditBox.Text; RowCount := RowCount + 1; EditBox.Text := ''; end; { with } end; { Вспомогательная процедура для сброса текста из выделенной строки текущей сетки на другую сетку. Если выполняется операция перемещения, строка удаляется из текущей сетки, которая затем "сжимается". } procedure TShareEventDemoForm.DropGridString (TargetGrid : TStringGrid);
var i : Integer; begin if TargetGrid <>
nil then begin with TargetGrid do begin Cells[0, RowCount - 1] := CurrentGrid.Cells[0, CurrentGrid.Row]; RowCount := RowCount + 1; end; { with } if not CopyDrag then with CurrentGrid do begin Cells[0, Row] := ''; if Row < RowCount - 1 then for i := Row to RowCount - 1 do Cells[0, i] := Cells[0, i + 1]; RowCount := RowCount - 1; end; { with } end; end; end.
Для правильного вычисления высоты и ширины строки, выводимой на корешке, мне пришлось прибегнуть к функциям Win95 API. Попутно я узнал пару интересных вещей. Во-первых, субсвойство Height свойства Font компонента включает высоту символа (вместе со строчными и подстрочными элемента ми), но не внутренний интервал (internal leading), используемый для специальных целей — например отображения диакритических знаков в некоторых символах национальных алфавитов.
Я захотел узнать настоящую высоту, возвращаемую при вызове GetText Metrics. Написанная мной функция FontHeight возвращает высоту по заданным логическим номерам компонента и шрифта. Внутри FontHeight я проверяю, что установлен координатный режим MM_TEXT — это означает, что полученное значение относится к выводу на экран и измеряется в пикселях.
Аналогичная методика используется и во вспомогательной функции String Width, передающей строку функции GetTextExtentPoint32. Возвращаемое значение равно приблизительной длине отображаемой строки (в пикселях). Значение считается приблизительным, поскольку в нем не учитывается возможный кернинг, выполняемый для символов шрифта.
Обработчик OnCreate формы вызывает процедуру SetTabSizes, чтобы узнать, нужно ли изменять размеры корешков. Если процедура определяет, что в режиме конструирования свойствам TabHeight и TabWidth компонента PageControl были присвоены ненулевые значения, она вмешивается в происходящее
и регулирует размеры корешков, учитывая метрики шрифта и длину самого длинного названия.
По свойству TabWidth и координате X, предоставляемой в ходе перетаскива ния, функция TabGrid определяет нужную вкладку и возвращает указатель на связанную с ней сетку. PageControlDragDrop также пользуется TabGrid, чтобы
определить, какая сетка должна получить сбрасываемую строку.
