Включение/выключение клавиатуры

Alexander V. Timoshenko делится своими секретами:

Некоторое время назад передо мной встала задача создать процедуру для отключения/включения клавиатуры. Я использовал один из Ваших "Советов" и исходники компонента, который нашел в Интернете, но, к сожалению, не знаю автора и его кординат. Вот основные выдержки из того, что получилось у меня в итоге. Думаю, тут нет ничего сложного.

// используемые переменные var Dummy     : integer=0; OldKbHook : HHook=0; impementation function KbHook( code: Integer; wparam: Word; lparam: LongInt ): LongInt; stdcall; begin if code<0 then Result:=CallNextHookEx( oldKbHook, code, wparam, lparam ) else Result:=1; end; // включение клавы procedure TForm1.KeyBoardOn(Sender: TObject); begin if OldKbHook <> 0 then begin UnHookWindowshookEx( OldKbHook ); OldKbHook := 0; end; SystemParametersInfo( SPI_SETFASTTASKSWITCH, 0, 0, 0); SystemParametersInfo( SPI_SCREENSAVERRUNNING, 0, 0, 0); end; // выключение клавы procedure TForm1.KeyBoardOff(Sender: TObject); begin SystemParametersInfo( SPI_SETFASTTASKSWITCH, 1, @Dummy, 0); SystemParametersInfo( SPI_SCREENSAVERRUNNING, 1, @Dummy, 0); OldKbHook := SetWindowsHookEx( WH_KEYBOARD, @KbHook, HInstance, 0 ); end;

Некоторые замечания по поводу этих процедур: Если программу упаковать UPX-ом - клава не будет отключаться (причин не знаю). В ДОС-окне клава будет работать (FAR, VC и т.п.) :( Состояния клавиш NumLock,CapsLock,ScrollLock не отслеживаются и могут быть изменены. Возможно EnableHardwareKeyboard более эффективен и прост, но я тоже, к сожалению, не знаю, как им пользоваться. Если вместо WH_KEYBOARD поставить WH_MOUSE, то можно выключать таким образом мышь :-) [001760]

Звуковой сигнал при нажатии <ENTER>

procedure TForm1.EditKeyPress(Sender: TObject; var Key:Char); begin if Key = Chr(VK_RETURN) then begin Perform(WM_NEXTDLGCTL,0,0); key:= #0; end; end;

[000137]

D-рамка для текстовых компонентов

Один из примеров создания текстового компонента с трехмерной декоративной контурной рамкой (для создания компонента потребовалось около получаса. Он демонстрирует только принцип получения рамки. Я не стал колдовать над свойствами типа ParentFont..., т.к. это заняло бы еще немало времени и места).

unit IDSLabel; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls; type TIDSLabel = class(TBevel) private { Private declarations } FAlignment : TAlignment; FCaption : String; FFont : TFont; FOffset : Byte; FOnChange : TNotifyEvent; procedure SetAlignment( taIn : TAlignment ); procedure SetCaption( const strIn : String); procedure SetFont( fntNew : TFont ); procedure SetOffset( bOffNew : Byte ); protected { Protected declarations } constructor Create( compOwn : TComponent ); override; destructor Destroy; override; procedure Paint; override; public { Public declarations } published { Published declarations } property Alignment : TAlignment read FAlignment write SetAlignment default taLeftJustify; property Caption : String read FCaption write SetCaption; property Font : TFont read FFont write SetFont; property Offset : Byte read FOffset write SetOffset; property OnChange : TNotifyEvent read FOnChange write FOnChange; end; implementation constructor TIDSLabel.Create; begin inherited Create(compOwn); FFont := TFont.Create; with compOwn as TForm do FFont.Assign(Font); Offset := 4; Height := 15; end; destructor TIDSLabel.Destroy; begin FFont.Free; inherited Destroy; end; procedure TIDSLabel.Paint; var wXPos, wYPos : Word; begin {Рисуем рамку} inherited Paint; {Назначаем шрифт} Canvas.Font.Assign(Font); {Вычисляем вертикальную позицию} wYPos := (Height - Canvas.TextHeight(Caption)) div 2; {Вычисляем горизонтальную позицию} wXPos := Offset; case Alignment of taRightJustify: wXPos := Width - Canvas.TextWidth(Caption) - Offset; taCenter: wXPos := (Width - Canvas.TextWidth(Caption)) div 2; end; Canvas.Brush := Parent.Brush; Canvas.TextOut(wXPos,wYPos,Caption); end; procedure TIDSLabel.SetAlignment; begin FAlignment := taIn; Invalidate; end; procedure TIDSLabel.SetCaption; begin FCaption := strIn; if Assigned(FOnChange) then FOnChange(Self); Invalidate; end; procedure TIDSLabel.SetFont; begin FFont.Assign(fntNew); Invalidate; end; procedure TIDSLabel.SetOffset; begin FOffset := bOffNew; Invalidate; end; end.

[000044]

Как сделать бегущую стpоку?

The_Sprite отвечает:

с помощью TLabel и TTimer. Пример:

procedure TForm1.Timer1Timer(Sender: TObject); Const LengthGoString = 10; GoString = 'В конце стpоку желательно повтоpить,'+ ' чтоб получить эффект кольцевого движения! В конце ст'; Const i: Integer = 1; begin Label1.Caption:=Copy(GoString,i,LengthGoString); Inc(i); If Length(GoString)-LengthGoString < i then i:=1; end;

[001534]

Комбинация TLabel и TEdit

unit Editlbl1; interface uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, stdctrls; type TLabelEdit = class(TWinControl) private { Private declarations } FEdit: TEdit; FLabel: TLabel; function GetLabelCaption: string; procedure SetLabelCaption(LabelCaption: string); function GetEditText: string; procedure SetEditText(EditText: string); protected { Protected declarations } public { Public declarations } constructor Create(AOwner: TComponent); override; published property LabelCaption: string read GetLabelCaption write SetLabelCaption; property EditText: string read GetEditText write SetEditText; property Left; property Top; property Width; property Height; property Text; property Font; { Можете опубликовать другие, необходимые вам свойства. } { Published declarations } end; procedure Register; implementation constructor TLabelEdit.Create(AOwner: TComponent); begin inherited Create(AOwner); FEdit := TEdit.Create(self); FLabel := TLabel.Create(self); with FLabel do begin Width := FEdit.Width; visible := true; Parent := self; Caption := 'LabelEdit'; end; with FEdit do begin Top := FLabel.Height+2; Parent := self; Visible := true; end; Top := 0; Left := 0; Width := FEdit.Width; Height := FEdit.Height+FLabel.Height; Visible := true; end; function TLabelEdit.GetLabelCaption: string; begin Result := FLabel.Caption; end; procedure TLabelEdit.SetLabelCaption(LabelCaption: string); begin FLabel.Caption := LabelCaption; end; function TLabelEdit.GetEditText: string; begin Result := FEdit.Text; end; procedure TLabelEdit.SetEditText(EditText: string); begin FEdit.Text := EditText; end; procedure Register; begin RegisterComponents('Test', [TLabelEdit]); end; end.

[000481]

SendMessage и TLabel

Вы не можете посылать сообщение элементу управления, не имеющему hWnd (т.е. свойство Handle в Delphi). Мне видится лучшим решением посылка сообщения невидимому элементу управления, который имеет дескриптор, и в его обработчике сообщения делать с Tlabel все, что вам заблагорассудится.

[001588]

TLabel+TEdit без контейнера

При размещении на форме, создается TLabel, расположенный выше поля редактирования. При перемещении поля редактирования, TLabel "следует" за ним. При удалении поля редактирования, TLabel также удаляется. Имеется свойство LabelCaption, так что вы можете редактировать заголовок Tlabel. Вероятно вам потребуются и другие свойства TLabel, типа Font, но этот код только демонстрирует технологию, так что развивайте его по своему усмотрению.

unit LblEdit; interface uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; type TLabelEdit = class(TEdit) private FLabel : TLabel ; procedure WMMove( var Msg : TWMMove ) ; message WM_MOVE ; protected procedure SetParent( Value : TWinControl ) ; override ; function  GetLabelCaption : string ; virtual ; procedure SetLabelCaption( const Value : string ) ; virtual ; public constructor Create( AOwner : TComponent ) ; override ; destructor Destroy ; override ; published property LabelCaption : string read GetLabelCaption write SetLabelCaption ; end; procedure Register; implementation constructor TLabelEdit.Create( AOwner : TComponent ) ; begin inherited Create( AOwner ) ; { создаем TLabel } FLabel := TLabel.Create( NIL ) ; FLabel.Caption := 'Edit label' ; end ; procedure TLabelEdit.SetParent( Value : TWinControl ) ; begin { убеждаемся, что TLabel имеет того же родителя что и TEdit } if ( Owner = NIL ) or not ( csDestroying in Owner.ComponentState ) then FLabel.Parent := Value ; inherited SetParent( Value ) ; end ; destructor TLabelEdit.Destroy ; begin if ( FLabel <> NIL ) and ( FLabel.Parent = NIL ) then FLabel.Free ; inherited Destroy ; end ; function  TLabelEdit.GetLabelCaption : string ; begin Result := FLabel.Caption ; end ; procedure TLabelEdit.SetLabelCaption( const Value : string ) ; begin FLabel.Caption := Value ; end ; procedure TLabelEdit.WMMove( var Msg : TWMMove ) ; begin inherited ; { заставляем TLabel 'прилипнуть' к верху TEdit } if FLabel <> NIL then with FLabel do SetBounds( Msg.XPos, Msg.YPos - Height, Width, Height ) ; end ; procedure Register; begin RegisterComponents('Samples', [TLabelEdit]); end; initialization { Мы используем TLabel, поэтому для обеспечения "поточности" необходима регистрация } RegisterClass( TLabel ) ; end.

- Mike Scott [000779]

Двойной ListBox

Я расположил на форме два компонента Listbox, и с помощью следующего кода заполнил один из них данными из таблицы:

tableName.Refresh;  {в вашем случае это может и не понадобится} tableName.First;    {Убедимся, что мы смотрим первую запись} while not tableName.Eof do {проходим в цикле таблицу} begin listbox1.items.add(tableName.FieldByName('USRID').AsString); {добавляем элемент в listbox1} tableName.Next; {переходим к следующей записи} end;

ниже я привел процедуру из моего рабочего кода, в котором я использую эту технологию. Я передаю ей в качестве параметров имя таблицы и имена компонентов listbox1 и listbox2. Я пользуюсь этой процедурой, поскольку у меня есть несколько таблиц с полями одинакового типа:

procedure TTemplateFrm.buildList(tableName: TTable; SelBox, AvailBox: TListBox); begin {в этой процедуре мы собираемся добавить данные в listbox'ы} {получаем любые новые данные} tableName.Refresh; {Убедимся, что мы смотрим первую запись} tableName.First; {Теперь очищаем ListBox'ы} SelBox.Clear; AvailBox.Clear; {Теперь добавляем элементы} while not tableName.EOF do begin AvailBox.Items.Add(tableName.fieldByName('USRID').AsString + ' ' + tableName.fieldByName('DESCRIPTION').AsString); tableName.Next; end; end;

Как перемещать данные между этими двумя списками? Если вы хотите использовать технологию "drag and drop" (перетащи и брось), то в обработчике mousedown вашей исходной таблицы воспользуйтесь процедурой begindrag:

if Button = mbLeft then Tlistbox(sender).BeginDrag(false);

Затем, в вашем другом ListBox, для "опознания" и получения данных создайте следующий обработчик DragOver:

if Source = ListBox1 then Accept := true else Accept := false;

Не используйте "Accept := (Source is TListbox)", как это показано в большинстве примеров. У вас имеется два компонента ListBox, следовательно, вам нужно сослаться на имя объекта, а не на его тип, а иначе программа просто не поймет кто есть кто.

Затем в обработчике dragDrop поместите следующий код, добавляющий данные в ListBox2 и удаляющий их из ListBox1.

Listbox2.Items.Add(Listbox1.Items[Listbox1.ItemIndex]); Listbox1.Items.Delete(Listbox1.ItemIndex);

И, наконец, добавьте кнопку "Сохранить", если вы хотите сохранить содержимое ListBox2 в базе данных.

Я надеюсь, что это именно то, что вы искали, и что это окажется вам полезным. Если вы хотите также перемещать данные из ListBox2 в ListBox1, вам необходимо будет создать тот же код, но реверсировать его для получения в коде правильных ссылок на компоненты ListBox. [001507]

Хранение переменных в ListBox

TListBox для хранения строк имеет собственный TStringList. TStringList имеет свойство items (или что-то типа этого), которое хранит указатели (или что-то еще, имеющее размер указателя или меньше). Так, например, вы можете хранить указатель на объект, компонент, запись или переменную соответственно в каждой строке TListBox. [001602]

Имя элемента ListBox

Воспользуйтесь свойствами Items и ItemIndex:

Foo := Bar.Items[Bar.ItemIndex];

Foo теперь должен содержать выбранный в ListBox элемент.

ShowMessage( Listbox1.Items[Listbox1.ItemIndex] );

[001566]

Инкрементальный поиск в ListBox I

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

procedure TForm1.Edit1Change(Sender: TObject); VAR Ndx : Word; begin WITH Sender AS TEdit DO BEGIN Ndx := ListBox1.Items.Add(Text); ListBox1.Items.Delete(Ndx); IF CompareText(Text, Copy(ListBox1.Items[Ndx],1,Length(Text)))=0 THEN ListBox1.ItemIndex := Ndx ELSE ListBox1.ItemIndex := -1; END; end;

Пытаясь вставить часть текста, вы просто просматриваете список на предмет его наличия. Если актуальный элемент в этой позиции содержит "частичный" текст, мы выводим его, в противном случае делаем так, чтобы ListBox не имел выделенного (ItemIndex) элемента. [000422]

Инкрементальный поиск в ListBox II

Я видел приложение, в котором ListBox позволял осуществлять инкрементальный поиск. При вводе очередного символа он позиционирует вас к первой ячейке, начало значения которой совпадает с введенным пользователем текстом, или выделяет все строки с текстом, содержащим введенный текст.

Как это осуществить на Delphi?

Здесь придется немного воспользоваться Win API. Установите свойство формы KeyPreview в True и сделайте примерно следующее:

unit LbxSrch; interface uses Windows, Messages, SysUtils, Classes, Controls, Forms, StdCtrls; type TFrmLbxSrch = class(TForm) Edit1: TEdit; Edit2: TEdit; ListBox1: TListBox; Label1: TLabel; procedure FormKeyPress(Sender: TObject; var Key: Char); procedure ListBox1Enter(Sender: TObject); private { Private declarations } FPrefix: array[0..255] of char; public { Public declarations } end; var FrmLbxSrch: TFrmLbxSrch; implementation {$R *.DFM} procedure TFrmLbxSrch.FormKeyPress(Sender: TObject; var Key: Char); { Помните о том, что свойство KeyPreview должно быть установлено в True } var curKey: array[0..1] of char; ndx:    integer; begin if ActiveControl = ListBox1 then begin if key = #8 {Backspace (клавиша возврата)} then begin if FPrefix[0] <> #0 then begin FPrefix[StrLen(FPrefix) - 1] := #0; end end else begin curKey[0] := Key; curKey[1] := #0; StrCat(FPrefix, curKey); ndx := SendMessage(ListBox1.Handle, LB_FINDSTRING, -1, longint(@FPrefix)); if ndx <> LB_ERR then ListBox1.ItemIndex := ndx; end; Label1.Caption := StrPas(FPrefix); Key := #0; end; end; procedure TFrmLbxSrch.ListBox1Enter(Sender: TObject); begin FPrefix[0] := #0; Label1.Caption := StrPas(FPrefix); end; end.

- Ralph Friedman [001115]

Использование выбранных элементов TListBox

...это будет действительно классно, если я смогу просто переместить выбранные элементы в StringList. Или, например, вообще удалить невыбранные элементы из ListBox.

Следующий код перемещает все выбранные элементы ListBox1 в ListBox2:

procedure TForm1.Button1Click(Sender: TObject); var ix:integer; begin with ListBox1 do begin if SelCount < 1 then exit; for ix := 0 to Items.Count-1 do if Selected[ix] then ListBox2.Items.Add(Items[ix]); for ix := Items.Count-1 downto 0 do if Selected[ix] then Items.Delete(ix); end; end;

=== Mike Orriss === [000692]

Изменение позиций элементов ListBox с помощью drag&drop II

Я хотел бы изменить порядок следования элементов в неотсортированном списке ListBox методом drag&drop, т.е. просто перетаскивая их мышью на нужное место. Будет еще лучше, если при удержании кнопки мыши перетаскиваемый элемент визуально перемещал бы вверх или вниз сам список (для определения своего нового месторасположения) до тех пор, пока клавиша мыши не будет отпущена (как я понял, автоматическое скроллирование - В.О.).

Попробуйте для начала это:

unit Draglb; interface uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; type TDragListBox = class(TListBox) private { Private declarations } protected { Protected declarations } public { Public declarations } procedure DragOver(Sender, Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean); procedure DragDrop(Sender, Source: TObject; X, Y: Integer); constructor Create(AOwner: TComponent); override; { Published declarations } end; procedure Register; implementation procedure Register; begin RegisterComponents('Custom', [TDragListBox]); end; constructor TDragListBox.Create(AOwner: TComponent); begin Inherited Create(AOwner); DragMode := dmAutomatic; OnDragDrop := DragDrop; OnDragOver := DragOver; end; procedure TDragListBox.DragOver(Sender, Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean); begin Accept := Source = Self; end; procedure TDragListBox.DragDrop(Sender, Source: TObject; X, Y: Integer); var Value: Integer; begin if Sender = Self then begin Value:=Self.ItemAtPos(Point(x,y), True); if Value = -1 then begin Self.Items.Add(Self.Items[Self.ItemIndex]); Self.Items.Delete( Self.ItemIndex); end else begin Self.Items.Insert(Value {+ 1}, Self.Items[Self.ItemIndex]); Self.Items.Delete( Self.ItemIndex); end; end; end; end.

Чтобы заставить элемент перемещаться в позицию каждого элемента, вам необходимо сопоставлять область текущего элемента с текущим положения курсора мыши. Для организации автоматического скроллирования также необходимо вычислять текущие координаты курсора.

Nick Hodges
Monterey, CA [000575]

Если вы хотите принимать перетаскиваемый объект, только если он представляет собой собственный элемент, то в обработчике OnDragOver вставьте строчку "Accept := Source=Sender;". Ниже приведен код, позволяющий сортировать элементы с помощью перетаскивания их мышкой внутри списка компонента. Вам также понадобится таймер для обеспечения функции автопрокручивания. Это означает, что при перетаскивании элемента в верхнюю часть списка, он при необходимости прокручивается вниз, дабы стали видны невидимые в верхней части списка элементы. Если вам не нужно такое поведение компонента, исключите из кода все строчки, имеющие отношение к таймеру, включая вторую строчку в обработчике события OnDragOver.

... private { Private declarations } GoingUp : Boolean; procedure TForm1.ListBox1DragOver(Sender, Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean); begin Accept := (Sender = Source) AND (TListBox(Sender).ItemAtPos(Point(X,Y),False) >= 0); {устанавливаем таймер для автопрокрутки} IF Accept THEN WITH Sender AS TListBox DO IF Y>Height-ItemHeight THEN BEGIN GoingUp := False; Timer1.Enabled := True; END ELSE IF Y>ItemHeight THEN BEGIN GoingUp := True; Timer1.Enabled := True; END ELSE Timer1.Enabled := False; end; procedure TForm1.ListBox1DragDrop(Sender, Source: TObject; X, Y: Integer); VAR NuPos: Integer; begin WITH Sender AS TListBox DO BEGIN NuPos := ItemAtPos(Point(X,Y),False); IF NuPos >= Items.Count THEN Dec(NuPos); Label1.Caption := Format('Перемещено из %d в %d', [ItemIndex, NuPos]); Items.Move(ItemIndex, NuPos); {выделяем перемещенный элемент} ItemIndex := NuPos; END; end; procedure TForm1.Timer1Timer(Sender: TObject); begin WITH ListBox1 DO IF GoingUp THEN IF TopIndex>0 THEN TopIndex := TopIndex-1 ELSE Timer1.Enabled := False ELSE IF TopIndex<Items.Count-1 THEN TopIndex := TopIndex+1 ELSE Timer1.Enabled := False; end; procedure TForm1.ListBox1EndDrag(Sender, Target: TObject; X, Y: Integer); begin Timer1.Enabled := False; end;

[000649]

Вот еще одна вариация сабжа.

procedure TPickParty.PickListBMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin if Button = mbLeft then with Sender as TListBox do begin DraggedPM:= ItemAtPos(Point(X,Y), True); if DraggedPM >l;= 0 then BeginDrag(False); end; end; procedure TPickParty.PickListBDragOver(Sender, Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean); begin if Source = PickListB then Accept:= True; end; procedure TPickParty.PickListBDragDrop(Sender, Source: TObject; X,Y: Integer); var NewIndex: integer; begin NewIndex:= PickListB.ItemAtPos(Point(X,Y), False); if NewIndex > PickListB.Items.Count-1 then NewIndex:= PickListB.Items.Count-1; PickListB.Items.Move(DraggedPM, NewIndex); PickListB.ItemIndex:= NewIndex; end;

- Peter Donnelly [000756]

Единственно интересный код:

procedure TForm1.ListBox1DragDrop(Sender, Source: TObject; X, Y: Integer); begin with (Sender as TListBox) do Items.Move(ItemIndex,ItemAtPos(Point(x,y),True)); end; procedure TForm1.ListBox1DragOver(Sender, Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean); begin Accept := (Sender=Source); end;

Не забудьте в ListBox присвоить свойству DragMode значение dmAutomatic.

[000150]

Изменение шрифта в Listbox

Вероятно иногда бывает полезным установить шрифт с фиксированной шириной символов в вашем Listbox.

Есть одно решение данной проблемы - использовать системные фиксированные шрифты - System-Fixed-Font (по крайней мере в Windows 3.11 -- как насчет Windows 95?). Единственную вещь, которую вы должны сделать - установить шрифт программным путем в момент создания формы.

Вот пример (здесь LB - ListBox), где шрифт устанавливается после добавления нескольких строк в ListBox:

LB.Items.Clear; for i := 0 to (SL.Count)-1 do begin LB.Items.Add(Copy(SL.Strings[i], 1, j-1)); end; { !!!!! ТЕПЕРЬ УСТАНАВЛИВАЕМ ЖЕЛАЕМЫЙ ШРИФТ !!!!! } { System_Fixed_Font или ANSI_Fixed_Font } SendMessage(LB.handle, wm_SetFont, GetStockObject(System_Fixed_Font), 1);

[000148]

Как добавить горизонтальную полосу прокрутки в TListBox?

Nomadic отвечает:

Компонент VCL TListBox автоматически реализует вертикальную полосу прокрутки. Полоска прокрутки появляется, когда окно списка слишком мало для показа всех элементов списка. Однако окно списка не показывает горизонтальной полосы прокрутки, когда какие-либо элементы списка имеют большую ширину, чем само окно списка. Конечно, есть возможность добавить горизонтальную полосу прокрутки. Добавьте следующий код в обработчик события OnCreate Вашей формы:

procedure TForm1.FormCreate(Sender: TObject); var i, MaxWidth: integer; begin MaxWidth := 0; for i := 0 to ListBox1.Items.Count - 1 do if MaxWidth < ListBox1.Canvas.TextWidth(ListBox1.Items.Strings[i]) then MaxWidth := ListBox1.Canvas.TextWidth(ListBox1.Items.Strings[i]); SendMessage(ListBox1.Handle, LB_SETHORIZONTALEXTENT, MaxWidth+2, 0); end;

Этот код находит ширину, в пикселах, самой длинной строки в окне списка. Затем он использует сообщение LB_SETHORIZONTALEXTENT для установки горизонтальной прокручиваемой ширины, в пикселах, для окна списка. Два дополнительных пиксела добавлены к MaxWidth, чтобы сдвинуть оконечные символы от правой границы окна списка. [001610]

Как сделать так, чтобы каждая строка в ListBox имела свой цвет?

У меня есть два примера процедур OnDrawItem:

procedure TTest.ListBox1DrawItem(Control: TWinControl; Index: Integer; Rect: TRect; State: TOwnerDrawState); begin With ( Control As TListBox ).Canvas Do Begin Case Index Of 0: Begin Font.Color  := clBlue; Brush.Color := clYellow; End; 1: Begin Font.Color  := clRed; Brush.Color := clLime; End; 2: Begin Font.Color  := clGreen; Brush.Color := clFuchsia; End; End; FillRect(Rect); TextOut(Rect.Left, Rect.Top, ( Control As TListBox ).Items[Index]); End; end;

Вышеприведенный код устанавливает различный цвет у фона и текста в зависимости от номера строки, но он не работает с выделенными/выбранными строками (кстати, не забудьте установить значение свойства ListBox1.Style равным lbOwnerDrawFixed.)

procedure TListTest.ListBox1DrawItem( Control: TWinControl; Index: Integer; Rect: TRect; State: TOwnerDrawState ); Const HighLight = 'LINE'; Var TempLine, TempText, TempHigh: String; TempLeft, TempTop, TempStart: Integer; OldColor: TColor; begin with ( Control as TListBox ).Canvas do begin FillRect( Rect ); TempLeft := Rect.Left + 3; TempTop := Rect.Top + 1; TempLine := ( Control as TListBox ).Items[ Index ]; While TempLine > '' Do Begin TempStart := Pos( HighLight, AnsiUpperCase( TempLine ) ); If TempStart > 0 Then Begin TempText := Copy( TempLine, 1, TempStart - 1 ); TempHigh := Copy( TempLine, TempStart, Length( HighLight ) ); Delete( TempLine, 1, TempStart + Length( HighLight ) - 1 ); End Else Begin TempText := TempLine; TempHigh := ''; TempLine := ''; End; If TempText > '' Then Begin TextOut( TempLeft, TempTop, TempText ); Inc( TempLeft, TextWidth( TempText ) ); End; If TempHigh > '' Then Begin OldColor := Font.Color; If odSelected In State Then Font.Color := clYellow Else Font.Color := clBlue; TextOut( TempLeft, TempTop, TempHigh ); Inc( TempLeft, TextWidth( TempHigh ) ); Font.Color := OldColor; End; End; end; end;

Это можно протестировать со следующими тремя строками:

'Строка номер один'
'Вторая строка'
'Это строчка номер три'

Есть несколько вещей, достойных упоминания:

Я использую параметр Control для приведения типов ( Control as TListBox ).Items[ Index ], что убедиться в том, что я использую данные ListBox, такой способ позволяет сделать общим данный обработчик события для нескольких компонентов TListBox, например, если у вас имеется пара ListBox на различных страницах TNoteBook.

OldColor и проверка параметра State позволяет быть уверенным, что выбранная строка содержит видимый цвет шрифта (множество видеодрайверов используют белый текст на синем фоне для выбранной строки).

Также я создаю небольшое свободное пространство вокруг текста - увеличиваю TListBox.ItemHeight и, соответственно, область вывода текста - TempLeft := Rect.Left + 3 и TempTop := Rect.Top + 1.

[000153]

Колонки в TListBox

Установите свойство TabWidth в редакторе свойств ListBox. Можете даже не пытаться найти это в файле помощи. К примеру, если ширина вашего listbox равняется 300 пикселей, установите значение TabWidth равным 100 или около этого.

При добавлении новых строк в ListBox разнесение элементов по колонкам возможно, к примеру, с помощью ключа ^I:

ListBox1.Items.Add('Колонка1'^I'Колонка2'^I'Колонка3');

Я проверил это только что еще раз - все действительно работает как надо. Но я до сих пор не разобрался как менять ширину колонок. И вы после этого будете слепо доверять документации? (Сарказм) [000149]

Компонент Check List

Вопрос:

Я ищу компонент ListBox, который может отображать квадратик с галочкой (check box) для выбранных элементов списка - компонент CheckList, если вам будет угодно (просто последний компонент содержит меньший набор характеристик, чем мне необходимо).

Загрузите 'Adding Graphics in your listboxes and comboboxes' (дополнительная графика для компонентов ListBox и Combobox) из Borland Technical Information - документ TI2793. Добавьте в ваш ListBox изображение неотмеченного квадратика. Используя событие двойного щелчока заменяйте изображение на отмеченный квадратик. Рисование графики в коде для компонентов ListBox и ComboBox

Способность добавления своей графики в ListBox и ComboBox может значительно изменить внешний вид компонентов, делая графику более дружественной при общении с пользователем.

В: Как мне вставить свою графику в Listbox или ComboBox???

Приведу здесь пример, шаг за шагом иллюстрирующий данную технологию.....

Создайте форму. Расположите на вашей форме компоненты ComboBox и Listbox. Измените свойство Style компонента ComboBox на csOwnerDrawVariable и свойство Style компонента ListBox на lbOwnerDrawVariable. Обработчик события OnDrawItem компонентов TListBox или TComboBox позволяет осуществить вывод как объекта (графики), так и строки элемента. В данном примере осуществляется вывод как графического объекта, так и строки. Создайте 5 переменных типа TBitmap в VAR секции вашей формы. Создайте процедуру для события формы OnCreate. Создайте процедуру для события ComboBox OnDraw. Создайте процедуру для события ComboBox OnMeasureItem. Освободите ресурсы в обработчике события формы OnClose.

{НАЧАЛО OWNERDRW.PAS} unit Ownerdrw; interface uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; type TForm1 = class(TForm) ComboBox1: TComboBox; ListBox1: TListBox; procedure FormCreate(Sender: TObject); procedure FormClose(Sender: TObject; var Action: TCloseAction); procedure ComboBox1DrawItem(Control: TWinControl; Index: Integer; Rect: TRect; State: TOwnerDrawState); procedure ComboBox1MeasureItem(Control: TWinControl; Index: Integer; var Height: Integer); procedure ListBox1DrawItem(Control: TWinControl; Index: Integer; Rect: TRect; State: TOwnerDrawState); procedure ListBox1MeasureItem(Control: TWinControl; Index: Integer; var Height: Integer); private { Private declarations } public { Public declarations } end; var Form1: TForm1; TheBitmap1, TheBitmap2, TheBitmap3, TheBitmap4, TheBitmap5 : TBitmap; implementation {$R *.DFM} procedure TForm1.FormCreate(Sender: TObject); begin TheBitmap1 := TBitmap.Create; TheBitmap1.LoadFromFile('C:\delphi\images\buttons\globe.bmp'); TheBitmap2 := TBitmap.Create; TheBitmap2.LoadFromFile('C:\delphi\images\buttons\video.bmp'); TheBitmap3 := TBitmap.Create; TheBitmap3.LoadFromFile('C:\delphi\images\buttons\gears.bmp'); TheBitmap4 := TBitmap.Create; TheBitmap4.LoadFromFile('C:\delphi\images\buttons\key.bmp'); TheBitmap5 := TBitmap.Create; TheBitmap5.LoadFromFile('C:\delphi\images\buttons\tools.bmp'); ComboBox1.Items.AddObject('Изображение1: Глобус', TheBitmap1); ComboBox1.Items.AddObject('Изображение2: Видео', TheBitmap2); ComboBox1.Items.AddObject('Изображение3: Механизм', TheBitmap3); ComboBox1.Items.AddObject('Изображение4: Ключ', TheBitmap4); ComboBox1.Items.AddObject('Изображение5: Инструмент', TheBitmap5); ListBox1.Items.AddObject('Изображение1: Глобус', TheBitmap1); ListBox1.Items.AddObject('Изображение2: Видео', TheBitmap2); ListBox1.Items.AddObject('Изображение3: Механизм', TheBitmap3); ListBox1.Items.AddObject('Изображение4: Ключ', TheBitmap4); ListBox1.Items.AddObject('Изображение5: Инструмент', TheBitmap5); end; procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction); begin TheBitmap1.Free; TheBitmap2.Free; TheBitmap3.Free; TheBitmap4.Free; TheBitmap5.Free; end; procedure TForm1.ComboBox1DrawItem(Control: TWinControl; Index: Integer; Rect: TRect; State: TOwnerDrawState); var Bitmap: TBitmap; Offset: Integer; begin with (Control as TComboBox).Canvas do begin FillRect(Rect); Bitmap := TBitmap(ComboBox1.Items.Objects[Index]); if Bitmap <> nil then begin BrushCopy(Bounds(Rect.Left + 2, Rect.Top + 2, Bitmap.Width, Bitmap.Height), Bitmap, Bounds(0, 0, Bitmap.Width, Bitmap.Height), clRed); Offset := Bitmap.width + 8; end; { отображаем текст } TextOut(Rect.Left + Offset, Rect.Top, Combobox1.Items[Index]) end; end; procedure TForm1.ComboBox1MeasureItem(Control: TWinControl; Index: Integer; var Height: Integer); begin height:= 20; end; procedure TForm1.ListBox1DrawItem(Control: TWinControl; Index: Integer; Rect: TRect; State: TOwnerDrawState); var Bitmap: TBitmap; Offset: Integer; begin with (Control as TListBox).Canvas do begin FillRect(Rect); Bitmap := TBitmap(ListBox1.Items.Objects[Index]); if Bitmap <> nil then begin BrushCopy(Bounds(Rect.Left + 2, Rect.Top + 2, Bitmap.Width, Bitmap.Height), Bitmap, Bounds(0, 0, Bitmap.Width, Bitmap.Height), clRed); Offset := Bitmap.width + 8; end; { отображаем текст } TextOut(Rect.Left + Offset, Rect.Top, Listbox1.Items[Index]) end; end; procedure TForm1.ListBox1MeasureItem(Control: TWinControl; Index: Integer; var Height: Integer); begin height:= 20; end; end. {КОНЕЦ OWNERDRW.PAS} {НАЧАЛО OWNERDRW.DFM} object Form1: TForm1 Left = 211 Top = 155 Width = 435 Height = 300 Caption = 'Form1' Font.Color = clWindowText Font.Height = -13 Font.Name = 'System' Font.Style = [] PixelsPerInch = 96 OnClose = FormClose OnCreate = FormCreate TextHeight = 16 object ComboBox1: TComboBox Left = 26 Top = 30 Width = 165 Height = 22 Style = csOwnerDrawVariable ItemHeight = 16 TabOrder = 0 OnDrawItem = ComboBox1DrawItem OnMeasureItem = ComboBox1MeasureItem end object ListBox1: TListBox Left = 216 Top = 28 Width = 151 Height = 167 ItemHeight = 16 Style = lbOwnerDrawVariable TabOrder = 1 OnDrawItem = ListBox1DrawItem OnMeasureItem = ListBox1MeasureItem end end {КОНЕЦ OWNERDRW.DFM}

[000151]

ListBox - OnChange

Это было два месяца тому назад. Я нашел это на одном из Delphi-сайтов. Не очень сложно и понятно.

UNIT Lbox; INTERFACE USES SysUtils, WinTypes, Messages, Classes, Controls, Graphics, Forms, Menus, StdCtrls; Type TCngListBox = Class(TListBox) private FOnChange : TNotifyEvent; FLastSel : integer; procedure Click; override; protected procedure Change; Virtual; published property OnChange : TNotifyEvent read FOnChange write FOnChange; public constructor create(AOwner : TComponent); override; End; Procedure Register; IMPLEMENTATION procedure TCngListBox.Change; begin FLastSel := ItemIndex; if assigned(FOnChange) then FOnChange(self); end; procedure TCngListBox.Click; begin inherited Click; if FLastSel <> ItemIndex then Change; end; constructor TCngListBox.Create; begin Inherited Create(AOwner); FLastSel := -1; end; procedure Register; begin RegisterComponents('FreeWare',[TCngListBox]); end; END.

[001547]

ListBox с графикой

Вот пример кода. Вам необходимо установить свойство ListBox Style в lbOwnerDrawFixed. Затем в обработчике события DrawItem мы попытаемся нарисовать изображение (смотри описание события OwnerDraw в справке по Delphi).

unit Listemas; interface uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; type TLTemas = class(TForm) ListBox1: TListBox; procedure FormActivate(Sender: TObject); procedure ListBox1DrawItem(Control: TWinControl; Index: Integer; Rect: TRect; State: TOwnerDrawState); private { Private declarations } public { Public declarations } end; var LTemas: TLTemas; implementation {$R *.DFM} procedure TLTemas.FormActivate(Sender: TObject); var Dibujo: TIcon; begin with ListBox1.Items do begin Dibujo := TIcon.create; Dibujo.LoadFromFile('.\ICO\justic.ico'); AddObject('Poder Legislativo y Partidos Politicos',Dibujo); Dibujo := TIcon.create; Dibujo.LoadFromFile('.\ICO\justic.ico'); AddObject('Poder Ejecutivo Nacional',Dibujo); end; end; procedure TLTemas.ListBox1DrawItem(Control: TWinControl; Index: Integer; Rect: TRect; State: TOwnerDrawState); var Icon: TIcon; Offset: Integer;    { ширина отступа текста } begin with (Control as TListBox).Canvas do { рисуем на холсте элемента управления, не на форме } begin FillRect(Rect); { очищаем прямоугольник } Offset := 2; { обеспечиваем отступ по умолчанию } Icon := TIcon((Control as TListBox).Items.Objects[Index]); { получаем иконку для данного элемента } if Icon <> nil then begin Draw(Rect.Left+1,Rect.Top+2,TIcon((Control as ListBox).Items.Objects[Index])); Offset := Icon.width + 9; { добавляем четыре пикселя между иконкой и текстом } end; TextOut(Rect.Left + Offset, Rect.Top+7, (Control as TListBox).Items[Index]) { выводим текст } end; end; end.

Воспользуйтесь событием OnDrawItem объекта ListBox (или ComboBox, или др.). В его обработчике рисовать графику так же легко, как и писать текст. (Полное управление вы получите после того, как подключите к своей работе обработку события OnMeasureItem)

procedure ListDrawItem(Control: TWinControl; Index: Integer; Rect: TRect; State: TOwnerDrawState); var BitMap : TBitMap; begin {Здесь инициализируем Bitmap.... например, загружаем в него изображение} With (Control as TListBox).Canvas do begin FillRect(Rect); Draw(Rect.Left, Rect.Top, BitMap); TextOut(Rect.Left + 2 + BitMap.Width, Rect.Top, DstList.items.strings[index]);  {DstList - имя списка} end; end;

[001548]

Навигация в ListBox при множественном выборе

Тема: Навигация в ListBox при множественном выборе

Данный пример выводит сообщение для каждого элемента Listbox, выбранного пользователем.

procedure TForm1.Button1Click(Sender: TObject); var Loop: Integer; begin for Loop := 0 to Listbox1.Items.Count - 1 do begin if Listbox1.Selected[Loop] then ShowMessage(Listbox1.Items.Strings[Loop]); end; end;

[001025]

Обнаружение прокрутки TListBox

Как мне определить, что потребитель двигает полосы прокрутки в Tlistbox?

Просто ловите сообщение WMVScroll...

Хмм, было бы неплохо отлавиливать это сообщение и генерировать для этого случая событие OnVScroll. Например так:

unit Listbob; interface uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; type TListBob = class(tlistbox) private { Private declarations } FOnHScroll: TNotifyEvent; FOnVScroll: TNotifyEvent; protected { Protected declarations } procedure WMHScroll(var Message: TWMHScroll); message WM_HSCROLL; procedure WMVScroll(var Message: TWMVScroll); message WM_VSCROLL; public { Public declarations } constructor Create(AOwner: TComponent); override; published { Published declarations } property OnHScroll: TNotifyEvent read FOnHScroll write FOnHScroll; property OnVScroll: TNotifyEvent read FOnVScroll write FOnVScroll; end; procedure Register; implementation constructor TListBob.Create(AOwner: TComponent); begin inherited Create(AOwner); FOnHScroll := nil; FOnVScroll := nil; end; procedure TListBob.WMHScroll(var Message: TWMHScroll); { помните что данное сообщение вызывается дважды!! } begin if Assigned(FOnHScroll) then FOnHScroll(Self); DefaultHandler(Message); end; procedure TListBob.WMVScroll(var Message: TWMHScroll); { помните что данное сообщение вызывается дважды!! } begin if Assigned(FOnVScroll) then FOnVScroll(Self); DefaultHandler(Message); end; procedure Register; begin RegisterComponents('Dr.Bob', [TListBob]); end; end.

Dr. Bob (drbob@pi.net) [000685]

Ownerdraw для Listbox

Вот пример обработчика OnDrawItem, выводящий английские гласные в красном цвете:

procedure TForm1.ListBox1DrawItem(Control: TWinControl; Index: Integer; Rect: TRect; State: TOwnerDrawState); VAR S : String; N : Word; WasColor : TColor; begin WITH Control AS TListBox, Canvas DO BEGIN S := Items[Index]; FillRect(Rect); MoveTo(Rect.Left+2, Rect.Top); SetTextAlign(Canvas.Handle, TA_LEFT OR TA_UPDATECP); WasColor := Font.Color; FOR N := 1 TO Length(S) DO BEGIN CASE UpCase(S[N]) OF 'A','E','I','O','U': Font.Color := clRed; ELSE Font.Color := WasColor; END; WinProcs.TextOut(Canvas.Handle, 0, 0, @S[N], 1); END; END; end;

Обратите внимание на то, что для того, чтобы использовать стиль TA_UPDATECP (при котором каждый следующий вызов TextOut выводил текст в позиции, расположенной после предшествуюшей), необходимо использовать функцию API function TextOut (WinProcs.TextOut) вместо метода объекта Delphi Canvas TextOut.

- Neil [000607]

Расширение компонента ListBox

Вот простое расширение TListBox. Двойное нажатие на элементе списка компонента не приводит пользователя к так ожидаемому выбору пункта, для этого приходится вначале выбрать элемент, а затем нажать на кнопку выбора; столь элементарная ожидаемая функциональность каждый раз должна обеспечиваться программистом; нижеприведенный код поможет избавиться от этой ненужной рутины.

Нижеприведенный компонент имеет дополнительное свойство DoubleClickBtn, отображающий список имеющихся на форме кнопок. Выберите одну из кнопок, и при двойном щелчке на одном из элементов списка компонента кнопка будет активизирована и вызван ее метод Click.

Вот код.

unit Unit1; interface uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; type TTraQsListBox = class(TListBox) private FDoubleClickBtn : TButton; protected procedure DblClick; override; public published property DoubleClickBtn : TButton read FDoubleClickBtn write FDoubleClickBtn; end; procedure Register; implementation {TTraQsListBox} procedure TTraQsListBox.DblClick; begin if Assigned(FDoubleClickBtn) then FDoubleClickBtn.Click else inherited DblClick; end; procedure Register; begin RegisterComponents('My Components', [TTraQsListBox]); end; end.

[000541]

Расширение TListBox

Я пытаюсь осуществить предварительную загрузку элементов наследника TListBox со множеством строк. Для этого я перекрываю конструктор, добавляя в него строки типа items.add('foo'); но когда я выполняю это, то получаю исключение "window has no parent window" (окно не имеет родительского окна). Почему у меня не получается сделать это?

Listbox сохраняет элементы, передавая их Windows. При этом требуется дескриптор окна, а дескриптору окна требуется родитель. Родитель не устанавливается даже после возврата из конструктора.

Решение проблемы: SaveVis := Visible; Visible := False; Parent := Owner; <заполнение ListBox> Parent := Nil; Visible := SaveVis; - Scott Samet [000950]

Щелчок в пустой области TListBox

Я хочу, чтобы мой TListBox имитировал поведение Delphi Watch List, отвечающий на двойной щелчок мышью диалоговым окном. Я добился такого эффекта, добавив обработку события OnDoubleClick к моей форме. Но в случае двойного щелчка в области, расположенной ниже последнего элемента списка, я хочу открывать диалоговое окно "добавить новый элемент". Но вот это никак не вытанцовывается. Метод OnDoubleClick не вызывается, если я щелкаю в TListBox, но щелчок приходится не на элемент списка, а на пустое место.

Попробуйте это....

Добавьте следующий обработчик OnMouseDown в ваш ListBox...

procedure TForm1.ListBox1MouseDown(...куча параметров...) begin if ( Button = mbLeft ) then begin with  Sender as TListBox  do begin if ( (ItemAtPos(Point(X,Y), True) = -1) and (ssDouble in Shift) ) then begin { ДВОЙНОЙ ЩЕЛЧОК В ПУСТОЙ ОБЛАСТИ } end; end; end; end;

Alan Ciemian
Ciemian Computer Services [000686]

Создание ListBox во время выполнения программы

Установка выравнивания ListBox на alLeft вызывает изменение размеров ListBox при любом изменении размеров формы. Установка ширины происходит очень легко (помните о том, что ширина Width, которую вы видите в правой части строки, является свойством Width формы).

Количество элементов, хранимых ListBox, ограничено только доступной памятью.

procedure TForm1.CreateListBox; var LB : TListBox; begin LB := TListBox.Create; LB.Align := alLeft; LB.Width := Width div 2; end;

Вот логика динамического создания ListBox и изменения его размера при изменения размеров формы. Я надеюсь, что помог вам. Также я подозреваю, что данные ListBox ограничены 32 килобайтами.

unit Unit1; interface uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls  { вам нужно это для ListBox }  ; type TForm1 = class(TForm) procedure FormCreate(Sender: TObject); procedure FormResize(Sender: TObject); private { Private declarations } public { Public declarations } end; var Form1: TForm1; listbox: TListBox ; implementation {$R *.DFM} procedure TForm1.FormCreate(Sender: TObject); begin listbox := TListBox.Create(self) ; listbox.Parent := self ; listbox.Top := 0 ; listbox.Left := 0 ; listbox.Width := self.Width div 2 ; listbox.Height := self.Height div 2 ; listbox.items.add('тест 1') ; listbox.items.add('тест 2') ; { и т.д, и т.п. ... } end; procedure TForm1.FormResize(Sender: TObject); begin listbox.Width := self.Width div 2 ; listbox.Height := self.Height div 2 ; end; end.

[001492]

TabStop в Listbox I

unit TabsLBox; {включение табуляторов в listbox} interface uses WinTypes, Classes, Controls, StdCtrls; type TMyListBox = class(TListBox) protected procedure CreateParams(var Params: TCreateParams); override; end; procedure register; implementation procedure register; begin RegisterComponents('Samples',[TMyListBox]); end; procedure TMyListBox.CreateParams(var Params: TCreateParams); begin inherited CreateParams(Params); Params.Style:= Params.Style or LBS_USETABSTOPS; end; end.

[000152]

Табуляция в графическом ListBox'е

Использование табуляции в ListBox'е когда компонент находится в стандартном режиме не составляет труда. Но что делать если надо использовать графическое отображение элементов списка? Ведь при этом надо самому писать обработчик отрисовки элементов с разбиением на колонки. Элементарное решение - использование API функции TabbedTextOut, однако результаты работы этой функции меня явно не удовлетворили. Пришлось-таки "выкручиваться"... Символ-разделитель можно использовать любой. Например, будем использовать символ "|", тогда обработчик OnDrawItem может выглядеть следующим образом:

procedure TBrowser.ListBox1DrawItem(Control: TWinControl; Index: Integer; Rect: TRect; State: TOwnerDrawState); var S, Ss: String; P: Integer; // Флаг символа-разделителя begin begin ListBox1.Canvas.FillRect(Rect); //Отрисовка графики ... // S:=ListBox1.Items.Strings[Index]; P:=Pos('|', S); If P=0 then Ss:=S else Ss:=Copy(S, 1, P-1); // Если нет табуляции, то пишем всю строку, иначе отрезаем кусок до разделителя ListBox1.Canvas.TextOut(Rect.Left + 20, Rect.Top + 2, Ss); If P>0 then ListBox1.Canvas.TextOut(ListBox1.TabWidth, Rect.Top + 2, Copy(S, P+1, Length(S)-P+2)); end; end;

Не забудьте перед запуском поставить нужное значение TabWidth.

Virtualik [001445]

Уменьшение мерцания ListBox в обработчике OwnerDraw

Предположим ListBox имеет в своем списке два элемента, элемент 0 имеет фокус, активен другой компонент и вы щелкаете на элементе 1. При этом происходит *ПЯТИКРАТНЫЙ* вызов OnDrawItem, смотрите сами изменения состояний двух элементов: Index State 0 [odSelected, odFocused] 0 [odSelected] 0 [] 1 [odSelected] 1 [odSelected, odFocused] В случае единственного элемента в списке ListBox получается конфуз, поскольку при щелчке на нем вы получаете тот же самый сценарий, только вместо двух индексов присутствует один, нулевой.

Имея эту информацию, вы можете минимизировать количество вызовов процедуры отрисовки. Для примера, в не-multi-select ListBox, элемент не нужно отрисовывать, если его состояние = [odSelected], поскольку это состояние всегда сопровождается НЕ selected НЕ focused, или ОДНОВРЕМЕННО selected и focused. В этом вам поможет технология отслеживания в обработчике OnDrawItem предыдущего отрисованного элемента, и если предыдущий запомненный элемент равен текущему, то отрисовывать его необязательно, например:

... const LastIndex : LongInt = -1; begin IF Index = LastIndex THEN ... ELSE ... LastIndex := Index; end;

- Neil [000548]

Внешние данные и ListBox

Мне необходимо создать Listbox с использованием внешних данных, хранимых в огромном (!) TStringList. Существует ли какое-нибудь системное сообщение, которое я мог бы перехватывать для получения данных Listbox из внешнего TStringlist?

Просматривая справочник по API, я нашел интересный пункт, который может помочь вам решить проблему: в Win32 вы можете создать Listbox со стилем LBS_NODATA:

(из описания CreateWindow:)

LBS_NODATA

Определяет ListBox со стилем no-data (без данных). Данный стиль необходимо применять в случае, если количество элементов в ListBox превышает одну тысячу. no-data ListBox также должен иметь стиль LBS_OWNERDRAWFIXED, но не может иметь стиль LBS_SORT или LBS_HASSTRINGS.

no-data ListBox похож на owner-drawn ListBox за исключением того, что он не содержит в своих элементах строк и изображений (иконок). Команды добавления, вставки или удаления данных в элементах такого типа ListBox будут проигнорированы, а запросы для поиска строк всегда будут заканчиваться неудачей. При необходимости отрисовки данного элемента, Windows посылает родительскому окну сообщение WM_DRAWITEM. Член itemID стуктуры DRAWITEMSTRUCT, передаваемой с сообщением WM_DRAWITEM, определяет номер строки (элемент), который должен быть перерисован. no-data ListBox не посылает сообщение WM_DELETEITEM.

Количество элементов в таком списке вы можете установить с помощью сообщения LB_SETCOUNT. Это позволит вам создать "виртуальный" ListBox с очень небольшой загрузкой.

Чтобы воспользоваться новым стилем, вам нужно создать новый класс-наследник от TListbox и перекрыть метод CreateParams.

- Peter Below [001038]

Выравнивание в ListBox'е

Перед тем, как вычислить позицию фразы, необходимо с помощью функции TextWidth вычислить ее ширину.

Например:

var J, TempInt, LongPrefixLen, CurrPrefixLen: Integer; begin {Вычисляем TextWidth по ключевой строке} {Устанавливаем CurrPrefixLen в TextWidth ключевого слова строки Indexth} LongPrefixLen := 0; for J := 0 to ListBox1.Items.Count-1 do with ListBox1.Canvas do begin TempInt:= TextWidth(Copy(Items[J],1,Pos(KeyString,Items[J]-1))); if LongPrefixLen < TempInt then LongPrefixLen:= TempInt; if J = Index then CurrPrefixLen:= TempInt; end; {PrevTextLeft - TextLeft = Где мы хотим вывести новый элемент} TextOut(LongPrefixLen-CurrPrefixLen,Y,Items[I]); end;

[001458]

TListView, TTreeView

У меня есть TTreeView и TListView, размещенные точно так же, как это сделано в Windows Explorer (фактически я хочу им придать и то же функциональное назначение). Как мне сделать следующее:

При двойном щелчке на элементе ListView узнать его индекс? Затем, как мне 'открыть' ветку и папку в компоненте TreeView, являющегося 'родителем' данного элемента? (В точном соответствии с функциональностью Проводника, к этому моменту родительский узел TreeView должен уже быть выбран - поэтому, я понимаю, необходимо правильно определить дочерний узел - но я чего-то запутался в синтаксисе).

Ниже приведен пример кода, показывающий как выбрать правильный узел дерева, по которому произведен двойной щелчок.

Как вы можете здесь видеть, ключем здесь является функция NodeAtIndex. Данный пример подразумевает наличие дочерних узлов и индексов, начиная с нуля. Так, если мы подразумеваем что был выбран родительский узел списка элементов, (что является безопасным предположением), то мы можем использовать данный узел как отправной пункт. Методы GetFirstChild и GetNextSibling "отправляют" вас к желаемому узлу.

function TFrmTipExplorer.NodeAtIndex( Index : Integer ) : TTreeNode; var I : Integer; begin Result := TreeView1.Selected.GetFirstChild; for I := 0 to Index - 1 do Result := Result.GetNextSibling; end; procedure TFrmTipExplorer.ListView1DblClick(Sender: TObject); begin TreeView1.Selected.Expand( False ); { Выбираем узел дерева, соответствующий "щелканному" элементу списка } NodeAtIndex( ListView1.Selected.Index ).Selected := True; end;

- Ray Konopka [000946]

Действие меню для нескольких форм

В вашей главной форме вам необходимо перехватывать нажатия клавиш и передавать их НЕ-MDI формам, вызывая их процедуры, т.е. идея заключается в неиспользовании обработчиков событий НЕ-MDI форм. Если такая идея вам нравится, то можно воспользоваться в главной форме событием onkeydown, где проверять нажатие пользователем ALT-комбинации клавиш прежде, чем будет вызвана процедура НЕ-MDI формы. Не забывайте вносить модули НЕ-MDI форм в список USES главной формы. Я надеюсь вы это уже сделали. Если изложенная выше идея вам не нравится, то единственный способ, который я знаю, заключается в передаче фокуса НЕ-MDI форме прежде, чем пользователь нажмет клавишу. [001769]

Динамическое добавление пунктов меню I

Решение 1

Честно говоря, я так и не понял к чему вы хотите добавлять новые пункты меню - к верхнему уровню или в качестве подменю. На всякий случай я публикую оба метода. Выбирайте любой.

Новый элемент верхнего уровня:

procedure tform1.addmainitem(s:string); var newitem : Tmenuitem; begin newitem:=tmenuitem.create(Mainmenu1); newitem.caption:=s; {если вы хотите определить событие onclick newitem.onclick:=Dynamenuclick; } {добавляем это к верхнему уровню меню} mainmenu1.items.insert(mainmenu1.items.count,newitem); removemenu1.enabled:=true; addmenuitem1.enabled:=true; end;

Создание подменю:

procedure tform1.addsubitem(s:string; to : integer); var newitem, toitem : Tmenuitem; begin {to = верхний уровень меню для нового пункта} toitem:=mainmenu1.items[to]; newitem:=tmenuitem.create(toitem); newitem.caption:=s; {если вы хотите определить событие onclick newitem.onclick:=Dynamenuclick; } toitem.onclick:=nil; toitem.insert(toitem.count,newitem); removemenuitem1.enabled:=true; end;

Решение 2

Вы можете использовать готовые функции, определенные в модуле Menus. Определения в Delphi 2:

function NewMenu(Owner: TComponent; const AName: string; Items: array of TMenuItem): TMainMenu; function NewPopupMenu(Owner: TComponent; const AName: string; Alignment: TPopupAlignment; AutoPopup: Boolean; Items: array of TMenuitem): TPopupMenu; function NewSubMenu(const ACaption: string; hCtx: Word; const AName: string; Items: array of TMenuItem): TMenuItem; function NewItem(const ACaption: string; AShortCut: TShortCut; AChecked, AEnabled: Boolean; AOnClick: TNotifyEvent; hCtx: Word; const AName: string): TMenuItem; function NewLine: TMenuItem;

Это превращает вышепоставленную задачу в сущий пустяк. [000176]

Динамическое добавление пунктов меню II

Вот пример программы, создающей структуру меню большой вложенности двумя различными способами. Она даст вам пищу для размышлений. Форма содержит компонент TMainMenu1 и, первоначально, одно подменю с именем SubMenu1.

unit Istopmnu; interface uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, Menus; type TForm1 = class(TForm) MainMenu1: TMainMenu; SubMenu1: TMenuItem; procedure AClick(Sender: TObject); procedure FormCreate(Sender: TObject); private { Private declarations } public { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.AClick(Sender: TObject); VAR TM : TMenuItem; Lev : Word; begin MessageBeep(0); TM := Sender AS TMenuItem; IF TM.Count > 0 THEN Caption := 'подменю' ELSE Caption := 'элемет меню'; Caption := Caption + ' с именем "' + TM.Name + '"'; Lev := 0; WHILE (TM.Parent <> NIL) AND (TM.Parent IS TMenuItem) DO BEGIN TM := TM.Parent; Inc(Lev); END; CASE Lev OF 1 : Caption := 'Верхний уровень ' + Caption; 2 : Caption := '2-й уровень ' + Caption; 3 : Caption := '3-й уровень ' + Caption; ELSE Caption := Format('%d-й уровень %s', [Lev, Caption]); END; end; procedure TForm1.FormCreate(Sender: TObject); VAR TM : TMenuItem; N  : Integer; begin TM := SubMenu1; TM.Add(NewItem('&Элемент',0,False,True,AClick,0,'MenuItem2')); FOR N := 2 TO 5 DO BEGIN TM.Add(TMenuItem.Create(nil)); TM := TM.Items[TM.Count-1]; TM.Caption := '&Меню'; TM.Name := 'SubMenu'+IntToStr(N); TM.OnClick := AClick; TM.Add(NewItem('&Элемент',0,False,True,AClick,0, 'MenuItem'+IntToStr(N+1))); END; MainMenu1.Items.Add(NewSubMenu('Меню&2', 0, 'SM1', [NewItem('&Элемент',0,False,True,AClick,0,'MI2'), NewSubMenu('&Меню', 0, 'SM2', [NewItem('&Элемент',0,False,True,AClick,0,'MI3'), NewSubMenu('&Меню', 0, 'SM3', [NewItem('&Элемент',0,False,True,AClick,0,'MI4'), NewSubMenu('&Меню', 0, 'SM4', [NewItem('&Элемент',0,False,True,AClick,0,'MI5'), NewSubMenu('&Меню', 0, 'SM5', [NewItem('&Элемент',0,False,True,AClick,0,'MI6') ]) ]) ]) ]) ])); TM := MainMenu1.Items[1]; WHILE TRUE DO BEGIN TM.OnClick := AClick; IF TM.Count < 2 THEN Break; TM := TM.Items[1]; END; end; end.

- Neil J. Rubenking [000769]

Добавление иконки в меню

Как добавить иконку в меню? Можно так:

var Bmp1 : TPicture; ... Bmp1 := TPicture.Create; Bmp1.LoadFromFile('c:\where\b1.BMP'); SetMenuItemBitmaps(     MenuItemTest.Handle, 0, MF_BYPOSITION, Bmp1.Bitmap.Handle, Bmp1.Bitmap.Handle); ...

Создаем изображение.

Загружаем какое-либо изображение формата .BMP.

Используем вызов API SetMenuItemBitmaps для подключения изображения к меню со следующими параметрами:

MenuItemTest - имя для горизонтального (верхнего) пункта меню 0,1 ... - пункты меню, которым необходимо добавить иконку (первый пункт имеет индекс 0). Первый дескриптор изображения ссылается на первую иконку, выводимую когда пункт меню неотмечен (невыбран). Второй - если пункт меню отмечен (checked). Возможно использование одного изображения (как в нашем случае).

Весь код необходимо разместить в обработчике события, возникающего при создании формы.

Результат: Это работает, но в качестве иконки выводится только правая верхняя часть изображения (которое поместилось). Известите меня, если вам удалось изменить высоту (или ширину) пункта меню соразмерно выводимому изображению. [000175]

Исправление иконок выключенных пунктов меню

VS пишет:

При использовании ListImage, в недоступных пунктах Menu пиктограммы отображаются некорректно. Это можно видеть на рисунке:

Ошибка связана с получением монохромного изображения в процедуре TCustomImageList.DoDraw. Однако ее можно исправить, если воспользоваться небольшой "заплаткой" - ScrambleBitmap.

procedure TCustomImageList.DoDraw(Index: Integer; Canvas: TCanvas; X, Y: Integer; Style: Cardinal; Enabled: Boolean); procedure ScrambleBitmap(var BMP: TBitmap); const RMask = $0000FF; RAMask = $FFFF00; GMask = $00FF00; GAMask = $FF00FF; BMask = $FF0000; BAMask = $00FFFF; var R,C: integer; Color: LongWord; begin with Bmp.Canvas do begin for C:= 0 to Bmp.Height - 1 do for R:= 0 to Bmp.Width - 1 do begin Color:= Pixels[R,C]; if ((Color = 0) or (Color = $FFFFFF)) then Continue; if (((Color and RMask > $7F) and (Color and RAMask > $0)) or ((Color and GMask > $7F00) and (Color and GAMask > $0)) or ((Color and BMask > $7F000) and (Color and BAMask > $0))) then Pixels[R,C]:= $FFFFFF else Pixels[R,C]:= 0; end; end; end; const ROP_DSPDxax = $00E20746; var R: TRect; DestDC, SrcDC: HDC; begin if HandleAllocated then begin if Enabled then ImageList_DrawEx(Handle, Index, Canvas.Handle, X, Y, 0, 0, GetRGBColor(BkColor), GetRGBColor(BlendColor), Style) else begin if FMonoBitmap = nil then begin FMonoBitmap:= TBitmap.Create; with FMonoBitmap do begin // Monochrome:= True; закомментировать!!! Width:= Self.Width; Height:= Self.Height; end; end; { Store masked version of image temporarily in FBitmap } FMonoBitmap.Canvas.Brush.Color:= clWhite; FMonoBitmap.Canvas.FillRect(Rect(0, 0, Self.Width, Self.Height)); ImageList_DrawEx(Handle, Index, FMonoBitmap.Canvas.Handle, 0,0,0,0, CLR_DEFAULT, 0, ILD_NORMAL); ScrambleBitmap(FMonoBitmap); // заплатка R:= Rect(X, Y, X+Width, Y+Height); SrcDC:= FMonoBitmap.Canvas.Handle; BitBlt(SrcDC, 0, 0, Width, Height, SrcDC, 0, 0, DSTINVERT); // добавить!!! { Convert Black to clBtnHighlight } Canvas.Brush.Color:= clBtnHighlight; DestDC:= Canvas.Handle; Windows.SetTextColor(DestDC, clWhite); Windows.SetBkColor(DestDC, clBlack); BitBlt(DestDC, X+1, Y+1, Width, Height, SrcDC, 0, 0, ROP_DSPDxax); { Convert Black to clBtnShadow } Canvas.Brush.Color:= clBtnShadow; DestDC:= Canvas.Handle; Windows.SetTextColor(DestDC, clWhite); Windows.SetBkColor(DestDC, clBlack); BitBlt(DestDC, X, Y, Width, Height, SrcDC, 0, 0, ROP_DSPDxax); end; end; end;

Теперь пиктограммы в Menu будут отображаться как на приведенном рисунке:

"Заплатку" можно использовать и в ToolBar, где ошибка аналогична. ToolBar без "заплатки":

ToolBar с "заплаткой":

[001637]

Элементы меню с правым выравниванием

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

Хитрость кроется в префиксе заголовка элемента меню, а именно в символе Backspace, т.е. Chr(8).

Я не смог это сделать во время разработки приложения, это нужно делать во время его работы (например, в процедуре FormCreate):

MenuName.Caption := Chr(8) + MenuName.Caption;

[001579]

Как рисовать картинки в пунктах меню (через OwnerDraw)?

Nomadic советует:

Смотри пример:

unit DN_Win; interface uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, Menus, StdCtrls, type TDNForm = class(TForm) MainMenu1: TMainMenu; cm_MainExit: TMenuItem; procedure FormCreate(Sender: TObject); procedure cm_MainExitClick(Sender: TObject); private { Private declarations } public { Public declarations } BM:TBitmap; Procedure WMDrawItem(var Msg:TWMDrawItem); message wm_DrawItem; Procedure WMMeasureItem(var Msg:TWMMeasureItem); message wm_MeasureItem; end; var DNForm : TDNForm; implementation {$R *.DFM} var Comm,yMenu : word; procedure TDNForm.FormCreate(Sender: TObject); begin {картинку в меню} yMenu:=GetSystemMetrics(SM_CYMENU); comm:=cm_MainExit.Command; ModifyMenu(MainMenu1.Handle,0,mf_ByPosition or mf_OwnerDraw,comm,'Go'); end;{TDNForm.FormCreate} procedure TDNForm.cm_MainExitClick(Sender: TObject); begin DNForm.Close; end;{TDNForm.cmExitClick} {для прорисовки меню} Procedure TDNForm.WMMeasureItem(var Msg:TWMMeasureItem); Begin with Msg.MeasureItemStruct^ do begin if ItemID=comm then begin ItemWidth:=yMenu; Itemheight:=yMenu; end; end; End;{WMMeasureItem} {} Procedure TDNForm.WMDrawItem(var Msg:TWMDrawItem); var MemDC:hDC; BM:hBitMap; mtd:longint; Begin with Msg.DrawItemStruct^ do begin if ItemID=comm then begin BM:=LoadBitMap(hInstance,'dver'); MemDC:=CreateCompatibleDC(hDC);{hDC входит в структуру TDrawItemStruct} SelectObject(MemDC,BM); {rcItem входит в структуру TDrawItemStruct} if ItemState=ods_Selected then mtd:=NotSrcCopy else mtd:=SrcCopy; StretchBlt(hDC,rcItem.left,rcItem.top,yMenu,yMenu,MemDC,0,0,24,23,mtd); DeleteDC(MemDC); DeleteObject(BM); end; end{with} End;{TDNForm.WMDrawItem} end.

[001154]

Назначение обработчика MenuItem OnClick

SomeMenuItem.OnClick := SomeMethod;

Имейте в виду, что SomeMethod должен быть методом объекта, а не автономной процедурой и иметь ту же форму, что и TNotifyEvent; т.е. метод должен принимать единственный параметр (Sender) типа TObject. [000540]

Очень длинные меню

Данный код изменяет количество пунктов меню в зависимости от текущего разрешения. Данная схема работает безукоризненно. В нижеприведенном коде mnuView - выводимое меню, HandleMenuClick - назначенный обработчик для события OnClick.

procedure TfrmMain.LoadViewMenu; var itemNum: integer; mnu: TMenuItem; menuItemHeight: integer; itemsPerColumn: integer; begin {удаляем все видимые пункты меню} while mnuView.Count > 0 do begin {метод Free удаляет пункт меню} mnuView.Items[0].Free; end; {находим высоту каждого пункта меню. Значение 2 получено в результате экспериментов} menuItemHeight := GetSystemMetrics(SM_CYMENU) + 2; {вычисляем количество пунктов в колонке меню} itemsPerColumn := screen.height div menuItemHeight; {создаем пункты меню} for itemNum := 0 to 99 do begin mnu := TMenuItem.Create(self); mnu.caption := 'Пункт ' + inttostr(itemNum); {при необходимости начинаем с новой колонки} if (itemNum mod itemsPerColumn = 0) and (itemNum>0) then begin mnu.break := mbBarBreak; end; {назначаем обработчик события OnClick} mnu.OnClick := HandleMenuClick; mnuView.Add(mnu); end; end;

[000177]

Озорные меню

В своем меню я хочу иметь графику. Но как мне сделать это?

Воспользуйтесь командой ModifyMenu. Тем не менее, Delphi 1.0 имеет привычку СТИРАТЬ изменения в пунктах меню, к примеру, созданных на основе изображения или отрисованных вручную. Если вы пользуетесь этими "фишками", вы НЕ должны осуществлять enable/disable или check/uncheck элементов меню через свойства. Вместо этого вы должны вызывать соответствующие функции Windows API. Вот демонстрационный пример из моей книги Delphi Programming Problem Solver, демонстрирующий элементы меню на основе изображений. Подразумевается, что вы создали форму и главное меню. Меню содержит пустое подменю File (необязательно) и меню верхнего уровня с именем Brush1. Ниже Brush1 вы должны иметь шесть пунктов подменю; их имена могут быть абстрактными, но в приведенном ниже коде они поименованы шестью стилями кисти. Вот сам код:

unit bitmenuu; interface uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls, Menus; type TForm1 = class(TForm) MainMenu1: TMainMenu; File1: TMenuItem; Brush1: TMenuItem; Horizontal1: TMenuItem; Vertical1: TMenuItem; FDiagonal1: TMenuItem; BDiagonal1: TMenuItem; Cross1: TMenuItem; DiagCross1: TMenuItem; procedure FormCreate(Sender: TObject); procedure BrushStyleClick(Sender: TObject); private { Private declarations } Bitmaps : ARRAY[0..5] OF TBitmap; public { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.FormCreate(Sender: TObject); VAR N : Integer; begin WITH Brush1 DO FOR N := 0 TO 5 DO BEGIN Bitmaps[N] := TBitmap.Create; WITH Bitmaps[N], Canvas DO BEGIN Width := 80; Height := 16; Brush.Color := clMenu; Rectangle(0,0,80,16); Brush.Color := clMenuText; Brush.Style := TBrushStyle(N+2); Rectangle(0,0,80,16); END; ModifyMenu(Handle, N, MF_BYPOSITION OR MF_BITMAP, GetMenuItemID(Handle, N), PChar(Bitmaps[N].Handle)); END; end; procedure TForm1.BrushStyleClick(Sender: TObject); VAR N : Integer; begin WITH Brush1 DO FOR N := 0 TO Count-1 DO {$IFDEF Win32} Items[N].Checked := Items[N]=Sender; {$ELSE} IF Items[N] = Sender THEN CheckMenuItem(Handle, N, MF_BYPOSITION OR MF_CHECKED) ELSE CheckMenuItem(Handle, N, MF_BYPOSITION OR MF_UNCHECKED); {$ENDIF} WITH Sender AS TMenuItem DO Brush.Style := TBrushStyle(Tag); Refresh; end; end.

OK, в обработчике события формы OnCreate мы создаем шесть изображений и используем ModifyMenu для их назначения каждому из шести пунктов подменю. В обработчике события OnClick мы, в зависимости от того используется Delphi 2.0 или нет, применяем ту или иную технологию установки атрибутов пункта меню. В Delphi 2.0 мы должны обойти все пункты меню и установить Checked в True только для тех пунктов, на которых щелкали мышью. В Delphi 1.0 мы должны воспользоваться API функцией CheckMenuItem. Попробуйте это!

- Neil Rubenking [000999]

Перехват клавиши SHIFT во время выбора пункта меню

Попробуйте это:

procedure TForm1.Menu11Click(Sender: TObject); begin {Проверяем нажатость клавиши Shift} if HiWord(GetKeyState(VK_SHIFT)) <> 0 then Label1.Caption := 'Shift' else {Проверяем нажатость клавиши Ctrl} if HiWord(GetKeyState(VK_CONTROL)) <> 0 then Label1.Caption := 'Control' else {Проверяем нажатость клавиши Alt} if HiWord(GetKeyState(VK_MENU)) <> 0 then Label1.Caption := 'Alt' else Label1.Caption := 'Никакая из управляющих клавиш не нажата'; end;

[000173]

Пункт меню "Помощь" в правой части окна

Пример помещения корневого пункта меню в правую часть окна:

unit ODMenuU; interface uses SysUtils, Windows, Messages, Classes, Graphics, Controls, Forms, Dialogs, Menus, StdCtrls; type TForm1 = class(TForm) MainMenu1: TMainMenu; FileItem1: TMenuItem; ExitItem1: TMenuItem; HelpItem1: TMenuItem; About1: TMenuItem; procedure FormCreate(Sender: TObject); private { Private declarations } public { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.FormCreate(Sender: TObject); begin { Перемещаем корневой пункт меню "Помощь" в правую часть окна } { Windows 95/NT 4 поддерживают это таким образом ... } {$IFNDEF ALTERNATIVEWAY} ModifyMenu(MainMenu1.Handle, 1, mf_ByPosition or mf_Popup or mf_Help, HelpItem1.Handle, '&Помощь'); {$ELSE} { ... а Win 3.xx таким образом: } HelpItem1.Caption := #8 + HelpItem1.Caption; {$ENDIF} end; end.

Это все! Просто? :)

Даже несмотря на то, что Microsoft в Windows Styles Guides говорит о недопустимости правого расположения пунктов меню, вы наперекор этому можете это сделать. Вам необходимо проверить файл электронной справки с описанием второго и третьего параметров функций GetMenuItemInfo и SetMenuItemInfo.

procedure TForm1.FormCreate(Sender: TObject); var MMI: TMenuItemInfo; MyMenu: hMenu; Buffer: array[0..79] of Char; begin MyMenu := GetMenu(Handle); // Handle является дескриптором формы, содержащей меню MMI.cbSize := SizeOf(MMI); MMI.fMask := MIIM_TYPE; MMI.dwTypeData := Buffer; MMI.cch := SizeOf(Buffer); GetMenuItemInfo(MyMenu, 1, True, MMI); // (..., 1, True, ...) означает что "Помощь" является вторым пунктом меню. MMI.fType := MMI.fType or MFT_RIGHTJUSTIFY; SetMenuItemInfo(MyMenu, 1, True, MMI); end;

И сразу после опубликования совета пришло мне письмо:

Все хорошо, но мне кажется правильнее так: (Меню постоянно меняется, и помнить о индексе?? Зачем, наименование не изменно, заголовок как правило тоже...)

procedure TForm1.FormCreate(Sender: TObject); begin { Перемещаем корневой пункт меню "Помощь" в правую часть окна } { Windows 95/NT 4 поддерживают это таким образом ... } {$IFNDEF ALTERNATIVEWAY} ModifyMenu(MainMenu1.Handle, 1, mf_ByPosition or mf_Popup or mf_Help, >>> ModifyMenu(MainMenu1.Handle, HelpItem1.MenuIndex, mf_ByPosition or mf_Popup or mf_Help, (мнение автора) HelpItem1.Handle, '&Помощь'); {$ELSE} { ... а Win 3.xx таким образом: } HelpItem1.Caption := #8 + HelpItem1.Caption; {$ENDIF} end;

С уважением, Вадим В. Приставко, pristavko@writeme.com Кольская АЭС [000178]

Слияние MDI-меню

Delphi не совсем корректно производит объединение меню в MDI приложениях. Если окно MDIChild максимально развернуто, и добавляется другое окно MDIChild, управляющее MDIChild меню (родительское основное меню) или исчезает совсем, или делает это на момент нажатия на него.

По всей видимости, для слияния меню Delphi использует InsertMenu() с MF_POSITION. Тем не менее, если дочернее MDI-окно максимально развернуто, Popup меню добавляется к меню MDI-приложения, вставляясь на одну позицию дальше, чем необходимо. Это стандартное поведение системы, поскольку системное меню активного дочернего окна включается в первую позицию панели меню MDI-окна.

Согласно WinSDK, если активное дочернее окно максимально развертывается, вставляется новое popup-меню, при этом к значению позиции добавляется 1 (единица). [000346]

---

---