www.adept7.kiev.ua

VCL


Вопрос:

Как разместить прозрачную надпись на TBitmap?

Пример:

procedure TForm1.Button1Click(Sender: TObject);
var
        OldBkMode : integer;
begin
        Image1.Picture.Bitmap.Canvas.Font.Color := clBlue;
        OldBkMode := SetBkMode(Image1.Picture.Bitmap.Canvas.Handle,TRANSPARENT);
        Image1.Picture.Bitmap.Canvas.TextOut(10, 10, 'Hello');
        SetBkMode(Image1.Picture.Bitmap.Canvas.Handle,OldBkMode);
end;


Наверх к содержанию

Вопрос:

Можно ли обратиться к колонке или строке grid'а по заголовку?

Ответ:

В следующем примере приведены две функции: GetGridColumnByName() и GetGridRowByName(),
которые возвращают колонку или строку, имеющую заданный заголовок (caption).

Пример:

procedure TForm1.FormCreate(Sender: TObject);
begin
        StringGrid1.Rows[1].Strings[0] := 'This Row';
        StringGrid1.Cols[1].Strings[0] := 'This Column';
end;

function GetGridColumnByName(Grid : TStringGrid; ColName : string): integer;
var
        i : integer;
begin
        for i := 0 to Grid.ColCount - 1 do
        if Grid.Rows[0].Strings[i] = ColName then 
        begin
        Result := i;
        exit;
        end;
        Result := -1;
end;

function GetGridRowByName(Grid : TStringGrid; RowName : string): integer;
var
        i : integer;
begin
        for i := 0 to Grid.RowCount - 1 do
        if Grid.Cols[0].Strings[i] = RowName then
        begin
        Result := i;
        exit;
        end;
        Result := -1;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
        Column : integer;
        Row : integer;
begin
        Column := GetGridColumnByName(StringGrid1, 'This Column');
        if Column = -1 then
        ShowMessage('Column not found')
        else
        ShowMessage('Column found at ' + IntToStr(Column));
        Row := GetGridRowByName(StringGrid1, 'This Row');
        if Row = -1 then
        ShowMessage('Row not found')
        else
        ShowMessage('Row found at ' + IntToStr(Row));
end;


Наверх к содержанию

Вопрос:

Как использовать клавишу-акселератор в TTabsheets? Я добавляю клавишу-акселератор
в заголовок каждого Tabsheet моего PageControl, но при попытке переключать
страницы этой клавишей программа пикает и ничего не происходит.

Ответ:
Можно перехватить сообщение CM_DIALOGCHAR.

Пример:
type
        TForm1 = class(TForm)
        PageControl1: TPageControl;
        TabSheet1: TTabSheet;
        TabSheet2: TTabSheet;
        TabSheet3: TTabSheet;
        private
        {Private declarations}
        procedure CMDialogChar(var Msg:TCMDialogChar);
        message CM_DIALOGCHAR;
        public
        {Public declarations}
end;

var
        Form1: TForm1;

implementation
{$R *.DFM}
procedure TForm1.CMDialogChar(var Msg:TCMDialogChar);
var
        i : integer;
begin
        with PageControl1 do
        begin
        if Enabled then
        for i := 0 to PageControl1.PageCount - 1 do
        if ((IsAccel(Msg.CharCode, Pages[i].Caption)) and
        (Pages[i].TabVisible)) then 
        begin
        Msg.Result:=1;
        ActivePage := Pages[i];
        exit;
        end;
        end;
        inherited;
end;


Наверх к содержанию

Вопрос:
Можно ли изменить число колонок и их ширину в компоненте TFileListBox?

Ответ:

В приведенном примере FileListBox приводится к типу TDirectoryListBox -
таким образом можно добавиь дополнительные колонки.

Пример:
with TDirectoryListBox(FileListBox1) do 
begin
        Columns := 2;
        SendMessage(Handle, LB_SETCOLUMNWIDTH, Canvas.TextWidth('WWWWWWWW.WWW'),0);
end;


Наверх к содержанию

Вопрос:
Как настроить табуляцию в компоненте TMemo?

Ответ:

Пошлите в Memo сообщение EM_SETTABSTOPS. Например установим первую позицию
табуляции на 20-й пиксел.

Пример:

procedure TForm1.FormCreate(Sender: TObject);
var
        DialogUnitsX : LongInt;
        PixelsX : LongInt;
        i : integer;
        TabArray : array[0..4] of integer;
begin
        Memo1.WantTabs := true;
        DialogUnitsX := LoWord(GetDialogBaseUnits);
        PixelsX := 20;
        for i := 1 to 5 do
        begin
        TabArray[i - 1] :=((PixelsX * i ) * 4) div DialogUnitsX;
        end;
        SendMessage(Memo1.Handle,
        EM_SETTABSTOPS,5,LongInt(@TabArray));
        Memo1.Refresh;
end;


Наверх к содержанию

Вопрос:
Как перехватить нажатия функциональных клавиш и стрелок?

Ответ:

Проверяйте значение переменной key на равенство VK_RIGHT, VK_LEFT, VK_F1
и т.д. на событии KeyDown формы.

Пример:

procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
        if Key = VK_RIGHT then
        Form1.Caption := 'Right';
        if Key = VK_F1 then
        Form1.Caption := 'F1';
end;


Наверх к содержанию

Вопрос:

При обработке события DrawCell компонента DrawGrid я пишу Font.Color :=
clRed; и получаю бесконечный цикл мерцаний. Почему?

Ответ:
Правильно укажите границы используемого канваса.

Пример:

If (Row = 0) then
        begin
        DrawGrid1.Canvas.Font.Color := clRed;
        DrawGrid1.Canvas.TextOut(Rect.Left,Rect.Top, IntToStr(Col));
        end;


Наверх к содержанию

Вопрос:

При использовании BitBtn Caption(текст) и картинка(bitmap) из файла не видны 
одновременно. Почему?

Ответ:

Это может происходить если картинка слишком велика. Класс TBitBtn сначала
рисует картинку, а затем выводит текст над, под, слева или справа от картинки
(в завивимости от свойства Layout). Если размер картинки такой же как у
всей кнопки для вывода текста просто не остается места. Если Вам нужно
получить кнопку такого же размера как Ваша картинка и видеть при этом надпись
на кнопке Вам придется выводить текст надписи непосредственно на канву
картинки.

Пример:
var
        bm : TBitmap;
        OldBkMode : integer;
begin
        bm := TBitmap.Create;
        bm.Width := BitBtn1.Glyph.Width;
        bm.Height := BitBtn1.Glyph.Height;
        bm.Canvas.Draw(0, 0, BitBtn1.Glyph);
        OldBkMode := SetBkMode(bm.Canvas.Handle, Transparent);
        bm.Canvas.TextOut(0, 0, 'The Caption');
        SetBkMode(bm.Canvas.Handle, OldBkMode);
        BitBtn1.Glyph.Assign(bm);
end;


Наверх к содержанию

Вопрос:

Можно ли изменить вид текстового курсора (каретки) edit'а или другого элемента 
управления Windows?

Ответ:

Можно! В примере показано как создать два цветных "bitmap'а": "улыбчивый"
и "хмурый" и присвоить их курсору edit'а. Для этого нужно перехватить оконную
процедуру edit'а. Чтобы сделать это заменим адрес оконной процедуры Edit'а
нашим собственным, а старую оконную процедуру будем вызывать по необходимости.
Пример показывает "улыбчивый" курсор при наборе текста и "хмурый" при забое
клавишей backspace.

Пример:

unit caret1;

interface

{$IFDEF WIN32}
uses
        Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls;
{$ELSE}
uses
        WinTypes, WinProcs, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, 
        StdCtrls;
{$ENDIF}

type
        TForm1 = class(TForm)
        Edit1: TEdit;
        procedure FormCreate(Sender: TObject);
        procedure FormDestroy(Sender: TObject);
        private
        {Private declarations}
        public
        {Public declarations}
        CaretBm : TBitmap;
        CaretBmBk : TBitmap;
        OldEditsWindowProc : Pointer;
end;

var
        Form1: TForm1;

implementation
{$R *.DFM}

type
{$IFDEF WIN32}
        WParameter = LongInt;
{$ELSE}
        WParameter = Word;
{$ENDIF}
        LParameter = LongInt;

{New windows procedure for the edit control}
function NewWindowProc(WindowHandle : hWnd; TheMessage : WParameter; ParamW : WParameter;
        ParamL : LParameter) : LongInt
{$IFDEF WIN32} stdcall; {$ELSE} ; export; {$ENDIF}
begin
{Call the old edit controls windows procedure}
        NewWindowProc := CallWindowProc(Form1.OldEditsWindowProc, WindowHandle,
        TheMessage, ParamW, ParamL);
        if TheMessage = WM_SETFOCUS then
        begin
        CreateCaret(WindowHandle, Form1.CaretBm.Handle, 0, 0);
        ShowCaret(WindowHandle);
        end;
        if TheMessage = WM_KILLFOCUS then
        begin
        HideCaret(WindowHandle);
        DestroyCaret;
        end;
        if TheMessage = WM_KEYDOWN then
        begin
        if ParamW = VK_BACK then
        CreateCaret(WindowHandle, Form1.CaretBmBk.Handle, 0, 0)
        else
        CreateCaret(WindowHandle, Form1.CaretBm.Handle, 0, 0);
        ShowCaret(WindowHandle);
        end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
{Create a smiling bitmap using the wingdings font}
        CaretBm := TBitmap.Create;
        CaretBm.Canvas.Font.Name := 'WingDings';
        CaretBm.Canvas.Font.Height := Edit1.Font.Height;
        CaretBm.Canvas.Font.Color := clWhite;
        CaretBm.Width := CaretBm.Canvas.TextWidth('J') + 2;
        CaretBm.Height := CaretBm.Canvas.TextHeight('J') + 2;
        CaretBm.Canvas.Brush.Color := clBlue;
        CaretBm.Canvas.FillRect(Rect(0, 0, CaretBm.Width, CaretBm.Height));
        CaretBm.Canvas.TextOut(1, 1, 'J');
{Create a frowming bitmap using the wingdings font}
        CaretBmBk := TBitmap.Create;
        CaretBmBk.Canvas.Font.Name := 'WingDings';
        CaretBmBk.Canvas.Font.Height := Edit1.Font.Height;
        CaretBmBk.Canvas.Font.Color := clWhite;
        CaretBmBk.Width := CaretBmBk.Canvas.TextWidth('L') + 2;
        CaretBmBk.Height := CaretBmBk.Canvas.TextHeight('L') + 2;
        CaretBmBk.Canvas.Brush.Color := clBlue;
        CaretBmBk.Canvas.FillRect(Rect(0,0, CaretBmBk.Width, CaretBmBk.Height));
        CaretBmBk.Canvas.TextOut(1, 1, 'L');
{Hook the edit controls window procedure}
        OldEditsWindowProc := Pointer(SetWindowLong(Edit1.Handle,GWL_WNDPROC, 
        LongInt(@NewWindowProc)));
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
{Unhook the edit controls window procedure and clean up}
        SetWindowLong(Edit1.Handle,GWL_WNDPROC, LongInt(OldEditsWindowProc));
        CaretBm.Free;
        CaretBmBk.Free;
end;


Наверх к содержанию

Вопрос:

При использовании модулей доступа к BDE (DbiTypes, DbiProcs, DbiErrs),
любая попытка вызвать процедуру abort выдает ошибку при компиляции при
вызове метода abort "Statement expected, but expression of type 'Integer'
found". Я пытался найти DbiTypes.pas, DbiProcs.pas и DbiErrs.pas чтобы
разобраться но не нашел этих файлов. Где расположены эти файлы и как обойти
ошибку?

Ответ:

Модули DbiTypes, DbiProcs, DbiErrs это псевдонимы модуля "BDE", обьявлены
в Projects->Options->Directories/Conditionals->Unit Aliases. Исходник модуля
DBE находится в каталоге "doc" и называется "BDE.INT". В этом файле обьявленна
константа ABORT со значением -2. Так как Вы хотите использовать процедуру
Abort(), которая обьявлена в модуле SysUtils, Вам нужно добавить префикс
SysUtils перед вызовом процедуры Abort.

Пример:

SysUtils.Abort;


Наверх к содержанию

Вопрос:
Почему при изменении цвета букв StatusBar'а ничего не происходит?

Ответ:

Status bar - стандартный элемент управления Windows, и соответственно цвет
его букв - значение clBtnText которое изменяется с помощью настроек в Control
Panel. Этот цвет черный по умолчанию и может изменяться в зависимости от
выбранной цветовой схемы. Другие стандартные элемент управления Windows,
например кнопки, также имеют цвет букв, настраиваемый из ControlPanel.
StatusBar и его панели имеют свойство "owner-draw", позволяющее Вам использовать
любой цвет букв.

Пример: ип файла за 

procedure TForm1.StatusBar1DrawPanel(StatusBar: TStatusBar;
        Panel: TStatusPanel; const Rect: TRect);
begin
        if Panel = StatusBar.Panels[0] then
        begin
        StatusBar.Canvas.Font.Color := clRed;
        StatusBar.Canvas.TextOut(Rect.Left, Rect.Top, 'Panel - 0')
        end 
        else
        begin
        StatusBar.Canvas.Font.Color := clGreen;
        StatusBar.Canvas.TextOut(Rect.Left, Rect.Top, 'Panel - 1');
        end;
end;


Наверх к содержанию

Вопрос:
Как сделать многострочную надпись на TBitBtn?

Ответ:
Выводите текст надписи непосредственно на "glyph" TBitBtn'а. См. пример.

Пример:

procedure TForm1.FormCreate(Sender: TObject);
var
        R : TRect;
        N : Integer;
        Buff : array[0..255] of Char;
begin
        with BitBtn1 do
        begin
        Caption := 'A really really long caption';
        Glyph.Canvas.Font := Self.Font;
        Glyph.Width  := Width - 6;
        Glyph.Height := Height - 6;
        R := Bounds(0, 0, Glyph.Width, 0);
        StrPCopy(Buff, Caption);
        Caption := '';
        DrawText(Glyph.Canvas.Handle,Buff,StrLen(Buff),R,
        DT_CENTER or DT_WORDBREAK or DT_CALCRECT);
        OffsetRect(R,(Glyph.Width - R.Right) div 2,
        (Glyph.Height - R.Bottom) div 2);
        DrawText(Glyph.Canvas.Handle,Buff,StrLen(Buff),R,
        DT_CENTER or DT_WORDBREAK);
        end;
end;


Наверх к содержанию

Вопрос:

Как изменить стиль шрифта RichEdit нажатиями соответствующих комбинаций
клавиш? (например включить курсив по нажатию Ctrl + I)

Ответ:
В примере стили шрифта меняются по нажатию след. комбинаций клавиш
        Ctrl + B - вкл/выкл жирного шрифта
        Ctrl + I - вкл/выкл наклонного шрифта
        Ctrl + S - вкл/выкл зачеркнутого шрифта
        Ctrl + U - вкл/выкл подчеркнутого шрифта


Пример:

const
        KEY_CTRL_B = 02;
        KEY_CTRL_I =  9;
        KEY_CTRL_S = 19;
        KEY_CTRL_U = 21;

procedure TForm1.RichEdit1KeyPress(Sender: TObject; var Key: Char);
begin
        case Ord(Key) of
        KEY_CTRL_B: 
        begin
        Key := #0;
        if fsBold in (Sender as TRichEdit).SelAttributes.Style then
        (Sender as TRichEdit).SelAttributes.Style :=
        (Sender as TRichEdit).SelAttributes.Style - [fsBold]
        else
        (Sender as TRichEdit).SelAttributes.Style :=
        (Sender as TRichEdit).SelAttributes.Style + [fsBold];
        end;
        KEY_CTRL_I:
        begin
        Key := #0;
        if fsItalic in (Sender as TRichEdit).SelAttributes.Style then
        (Sender as TRichEdit).SelAttributes.Style :=
        (Sender as TRichEdit).SelAttributes.Style - [fsItalic]
        else
        (Sender as TRichEdit).SelAttributes.Style :=
        (Sender as TRichEdit).SelAttributes.Style + [fsItalic];
        end;
        KEY_CTRL_S:
        begin
        Key := #0;
        if fsStrikeout in (Sender as TRichEdit).SelAttributes.Style then
        (Sender as TRichEdit).SelAttributes.Style :=
        (Sender as TRichEdit).SelAttributes.Style-[fsStrikeout]
        else
        (Sender as TRichEdit).SelAttributes.Style :=
        (Sender as TRichEdit).SelAttributes.Style+[fsStrikeout];
        end;
        KEY_CTRL_U:
        begin
        Key := #0;
        if fsUnderline in (Sender as TRichEdit).SelAttributes.Style then
        (Sender as TRichEdit).SelAttributes.Style :=
        (Sender as TRichEdit).SelAttributes.Style-[fsUnderline]
        else
        (Sender as TRichEdit).SelAttributes.Style :=
        (Sender as TRichEdit).SelAttributes.Style+[fsUnderline];
        end;
        end;
end;


Наверх к содержанию

Вопрос:

Можно ли динамически изменять свойство "owner" компонента во время выполнения программы?

Ответ:

Вы можете менять свойство "owner" и после создания компонента с помощью
методов InsertComponent() и RemoveComponent().

Наверх к содержанию

Вопрос:

Как очистить содержимое Canvas'а?

Ответ:

Просто нарисуйте прямоугольник любого цвета.

Пример:

Canvas.Brush.Color := ClWhite;
Canvas.FillRect(Canvas.ClipRect);


Наверх к содержанию

Вопрос:

Как программно "щелкнуть" по компоненту speed button? Я пытался использовать
SendMessage но у Speedbuttons нет "handle".

Ответ:
В примере используется метод Perform класса TControl для отправки сообщения.

Пример:

procedure TForm1.SpeedButton1Click(Sender: TObject);
begin
        ShowMessage('clicked');
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
        SpeedButton1.Perform(WM_LBUTTONDOWN, 0, 0);
        SpeedButton1.Perform(WM_LBUTTONUP, 0, 0);
end;

Наверх к содержанию

Вопрос:
Можно ли отключить определенный элемент в RadioGroup?

Ответ:
В примере показано как получить доступ к отдельным элементам компонента TRadioGroup.

Пример:

procedure TForm1.Button1Click(Sender: TObject);
begin
        TRadioButton(RadioGroup1.Controls[1]). Enabled := False;
end;


Наверх к содержанию

Вопрос:

Почему методы рисования Delphi (например MoveTo и LineTo) рисуют на один пиксел короче?

Ответ:

Так работает большинство графических систем, включая Windows. Библиотека
VCL просто передает вызовы в функции GDI. Если Вы хотите нарисовать линию
с последним пикселом включительно просто добавте единицу к координатам.

Наверх к содержанию

Вопрос:
Как показать подсказки "hints" для элементов меню?

Ответ:

В примере создается обработчик события Application.Hint - подсказки меню изображаются
на status panel.

Пример:

type
        TForm1 = class(TForm)
        Panel1: TPanel;
        MainMenu1: TMainMenu;
        MenuItemFile: TMenuItem;
        MenuItemOpen: TMenuItem;
        MenuItemClose: TMenuItem;
        OpenDialog1: TOpenDialog;
        procedure FormCreate(Sender: TObject);
        procedure MenuItemCloseClick(Sender: TObject);
        procedure MenuItemOpenClick(Sender: TObject);
        private
        {Private declarations}
        procedure HintHandler(Sender: TObject);
        public
        {Public declarations}
end;

var
        Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
        Panel1.Align := alBottom;
        MenuItemFile.Hint := 'File Menu';
        MenuItemOpen.Hint := 'Opens A File';
        MenuItemClose.Hint := 'Closes the Application';
        Application.OnHint := HintHandler;
end;

procedure TForm1.HintHandler(Sender: TObject);
begin
        Panel1.Caption := Application.Hint;
end;

procedure TForm1.MenuItemCloseClick(Sender: TObject);
begin
        Application.Terminate;
end;

procedure TForm1.MenuItemOpenClick(Sender: TObject);
begin
        if OpenDialog1.Execute then
        Form1.Caption := OpenDialog1.FileName;
end;


Наверх к содержанию

Вопрос:
Как опеделить состояние списка ComboBox, выпал/скрыт?

Ответ:
Пошлите ComboBox сообщение CB_GETDROPPEDSTATE.

Пример:

if SendMessage(ComboBox1.Handle, CB_GETDROPPEDSTATE,0,0) = 1 then
        begin {список ComboBox выпал}

        end;


Наверх к содержанию

Вопрос:

Как извлечь Red, Green, и Blue компонент из определенного цвета?

Ответ:

Используйте функции Window API Get RValue(), GetGValue(), и GetBValue().

Пример:

procedure TForm1.Button1Click(Sender: TObject);
begin
        Form1.Canvas.Pen.Color := clRed;
        Memo1.Lines.Add('Red := ' + IntToStr(GetRValue(Form1.Canvas.Pen.Color)));
        Memo1.Lines.Add('Red := ' + IntToStr(GetGValue(Form1.Canvas.Pen.Color)));
        Memo1.Lines.Add('Blue:= ' + IntToStr(GetBValue(Form1.Canvas.Pen.Color)));
end;



Наверх к содержанию

Вопрос:
Как определить номер текущей строки в TMemo?

Ответ:

Чтобы определить номер текущей строки любого объекта управления edit -
пошлите ей сообщение EM_LINEFROMCHAR

Пример:

procedure TForm1.Button1Click(Sender: TObject);
var
        LineNumber : integer;
begin
        LineNumber := SendMessage(Memo1.Handle, EM_LINEFROMCHAR, word(-1), 0);
        ShowMessage(IntToStr(LineNumber));
end;


Наверх к содержанию

Вопрос:
Как использовать анимированный курсор?

Ответ:

Во первых необходимо получит handle курсора, а затем определить его в массиве
курсоров компонента TScreen. Индексы предопределенных курсоров системы
отрицательны, пользователь может определить курсор, индекс которого положителен.

Пример:

procedure TForm1.Button1Click(Sender: TObject);
var
        h : THandle;
begin
        h := LoadImage(0, 'C:\TheWall\Magic.ani', IMAGE_CURSOR, 0, 0, LR_DEFAULTSIZE or
        LR_LOADFROMFILE);
        if h = 0 then
        ShowMessage('Cursor not loaded')
        else
        begin
        Screen.Cursors[1] := h;
        Form1.Cursor := 1;
        end;
end;


Наверх к содержанию

Вопрос:
Как узнать о нажатии "non-menu" клавиши в момент когда меню показано?

Ответ:
Создайте обработчик сообщения WM_MENUCHAR.

Пример:

unit Unit1;

interface

uses
        Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Menus;

type 
        TForm1 = class(TForm)
        MainMenu1: TMainMenu;
        One1: TMenuItem;
        Two1: TMenuItem;
        THree1: TMenuItem;
        private
        {Private declarations}
        procedure WmMenuChar(var m : TMessage); message WM_MENUCHAR;
        public
        {Public declarations}
end;

var
        Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.WmMenuChar(var m : TMessage);
begin
        Form1.Caption := 'Non standard menu key pressed';
        m.Result := 1;
end;
end.


Наверх к содержанию

Вопрос:
Как вывести на элемент управления (Window control) текст, содержащий амперсанд - & ?

Ответ:

Используя два амперсанда подряд. Windows интерпритирует одиночный амперсанд
как указание на то, что следующий символ - горячая клавиша (и поддчеркивает
следующий символ вместо излбражения аперсанда).

Пример:

Button1.Caption := 'Черное && Белое';

Наверх к содержанию

Вопрос:
Как поместить bitmap в Metafile?

Ответ: см. пример

Пример:

procedure TForm1.Button1Click(Sender: TObject);
var
        m : TmetaFile;
        mc : TmetaFileCanvas;
        b : tbitmap;
begin
        m := TMetaFile.Create;
        b := TBitmap.create;
        b.LoadFromFile('C:\SomePath\SomeBitmap.BMP');
        m.Height := b.Height;
        m.Width := b.Width;
        mc := TMetafileCanvas.Create(m, 0);
        mc.Draw(0, 0, b);
        mc.Free;
        b.Free;
        m.SaveToFile('C:\SomePath\Test.emf');
        m.Free;
        Image1.Picture.LoadFromFile('C:\SomePath\Test.emf');
end;


Наверх к содержанию

Вопрос:
Как программно определить, что приложение работает под Windows NT?

Ответ:см. пример

Пример:

function IsNT : bool;
var
        osv : TOSVERSIONINFO;
begin
        result := true;
        GetVersionEx(osv);
        if osv.dwPlatformId = VER_PLATFORM_WIN32_NT then exit;
        result := false;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
        if IsNt then
        ShowMessage('Running on NT')
        else
        ShowMessage('Not Running on NT');
end;


Наверх к содержанию

Вопрос:
Как создать bitmap из пиктогрммы (icon)?

Ответ:
Используя Bitmap.Canvas.Draw нарисуйте пиктограмму на Bitmap'е.

Пример:

procedure TForm1.Button1Click(Sender: TObject);
var
        TheIcon : TIcon;
        TheBitmap : TBitmap;
begin
        TheIcon := TIcon.Create;
        TheIcon.LoadFromFile('C:\Program Files\Borland\IcoCur32\EARTH.ICO');
        TheBitmap := TBitmap.Create;
        TheBitmap.Height := TheIcon.Height;
        TheBitmap.Width := TheIcon.Width;
        TheBitmap.Canvas.Draw(0, 0, TheIcon);
        Form1.Canvas.Draw(10, 10, TheBitmap);
        TheBitmap.Free;
        TheIcon.Free;
        end;


Наверх к содержанию

Вопрос:
  Как создать отдельную подсказку (hint) для каждой ячейки StringGrid?

Ответ:

В приведенном примере отслеживается движение курсора мыши - при перемещении
между ячейками StringGrid'а - появляется окно подсказки(hint), показываеющее
номер текущей строки и колонки.

Пример:

type
        TForm1 = class(TForm)
        StringGrid1: TStringGrid;
        procedure StringGrid1MouseMove(Sender: TObject;
        Shift: TShiftState; X, Y: Integer);
        procedure FormCreate(Sender: TObject);
        private
        {Private declarations}
        Col : integer;
        Row : integer;
        public
        {Public declarations}
   end;

var
        Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
        StringGrid1.Hint := '0 0';
        StringGrid1.ShowHint := True;
end;

procedure TForm1.StringGrid1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
var
        r : integer;
        c : integer;
begin
        StringGrid1.MouseToCell(X, Y, C, R);
        with StringGrid1 do
        begin
        if ((Row <> r) or(Col <> c)) then
        begin
        Row := r;
        Col := c;
        Application.CancelHint;
        StringGrid1.Hint :=IntToStr(r)+#32+IntToStr(c);
        end;
        end;
end;


Наверх к содержанию

Вопрос:
Как внести изменения в код VCL?

Ответ:

Примечание: внесение изменений в VCL не поддерживается Borland или Borland
Developer Support.

-Но если Вы решили сделать это...

Изменеия в код VCL никогда не должны вносится в секцию "interface"
модуля - только в секцию "implimentation". Наиболее безопасный способ внести
изменения в VCL - создать новый каталог названный "исправленный VCL". Скопируйте
файл VCL который Вы хотите изменить в этот каталог. Внесите изменения (лучше
прокомментировать их) в этот файл. Затем добавьте путь к Вашему каталогу
"исправленный VCL" в самое начало "library path". Перезапустите Delphi/C++
Builder и перекомпилируйте Ваш проект. "library path" можно изменить в
меню:

Delphi 1 : Options | Environment | Library
Delphi 2 : Tools | Options | Library
Delphi 3 :  Tools | Environment Options | Library
Delphi 4 :  Tools | Environment Options | Library
C++ Builder : Options | Environment | Library


Наверх к содержанию

Вопрос:

Как в Delphi реализовать функцию - эквивалент TwipsPerPixel из VisualBasic?

Ответ:
Функции  TwipsPerPixelX и TwipsPerPixelY, приведенные в примере реализуют ту же
функциональность в  Delphi.

Пример:

function TwipsPerPixelX(Canvas : TCanvas) : Extended;
begin
        result := 1440 / GetDeviceCaps(Canvas.Handle, LOGPIXELSX);
end;

function TwipsPerPixelY(Canvas : TCanvas) : Extended;
begin
        result := 1440 / GetDeviceCaps(Canvas.Handle, LOGPIXELSY);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
        ShowMessage(FloatToStr(TwipsPerPixelX(Form1.Canvas)));
        ShowMessage(FloatToStr(TwipsPerPixelY(Form1.Canvas)));
end;


Наверх к содержанию

Вопрос:
Как вставить содержимое файла в текущую позицию курсора в компонете TMemo?

Ответ:

Считайте файл в TMemoryStream, затем ипользуйте метод TMemo SetSelTextBuf()
для вставки текста;

var
        TheMStream : TMemoryStream;
        Zero : char;
begin
        TheMStream := TMemoryStream.Create;
        TheMStream.LoadFromFile('C:\AUTOEXEC.BAT');
        TheMStream.Seek(0, soFromEnd); 
        //Null terminate the buffer!
        Zero := #0;
        TheMStream.Write(Zero, 1);
        TheMStream.Seek(0, soFromBeginning);
        Memo1.SetSelTextBuf(TheMStream.Memory);
        TheMStream.Free;
end;


Наверх к содержанию

Вопрос:

Как в компоненте TMemo перехватить нажатие Ctrl-V и вставить специальный
текст не из буфера обмена (clipboard)?

Ответ:
См. пример.

Пример:

uses ClipBrd;

procedure TForm1.Memo1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
        if ((Key = ord('V')) and (ssCtrl in Shift)) then
        begin
        if Clipboard.HasFormat(CF_TEXT) then 
        ClipBoard.Clear;
        Memo1.SelText := 'Delphi is RAD!';
        key := 0;
        end;
end;


Наверх к содержанию

Вопрос:

Как создать эквивалент TEdit но только с выравниваением вводимого текста
по центру или по правой стороне?

Ответ:

TEdit не поддерживает выравниваение текста по центру и по правой стороне
- лучше использовать компонент TMemo. Вам понадобится запретить пользователю
нажимать Enter, Ctrl-Enter и всевозможные комбинации клавиш со стрелками,
чтобы избежать появления нескольких сторк в Memo. Этого можно добиться
и просматривая содержимое текста в TMemo в поисках кода возврата каретки
(13) и перевода строки(10) на событиях TMemo Change и KeyPress. Можно также
заменять код возврата каретки на пробел - для того чтобы позволять вставку
из буфера обмена многострочного текста в виде одной строки.

Пример:

procedure TForm1.FormCreate(Sender: TObject);
begin
        Memo1.Alignment := taRightJustify;
        Memo1.MaxLength := 24;
        Memo1.WantReturns := false;
        Memo1.WordWrap := false;
end;

procedure MultiLineMemoToSingleLine(Memo : TMemo);
var
        t : string;
begin
        t := Memo.Text;
        if Pos(#13, t) > 0  then
        begin
        while Pos(#13, t) > 0 do
        delete(t, Pos(#13, t), 1);
        while Pos(#10, t) > 0 do
        delete(t, Pos(#10, t), 1);
        Memo.Text := t;
        end;
end;

procedure TForm1.Memo1Change(Sender: TObject);
begin
        MultiLineMemoToSingleLine(Memo1);
end;

procedure TForm1.Memo1KeyPress(Sender: TObject; var Key: Char);
begin
        MultiLineMemoToSingleLine(Memo1);
end;



Наверх к содержанию

Вопрос:

Как запрограммировать undo?

Ответ:См. пример

Memo1.Perform(EM_UNDO, 0, 0);

Если Вы хотите узнать, возможно ли выполнить операцию "Undo", проверьте "Undo status":

If Memo1.Perform(EM_CANUNDO, 0, 0) <> 0 then
begin
        {Undo is possible}
end;

Для выполнения "Redo" выполните "Undo" еще раз.


Наверх к содержанию

Вопрос:
Почему при изменении цвета шрифта в StatusBar's он (шрифт) не меняется?

Ответ:

Status bar (строка состояния) - стандартный элемент управления Windows
и цвет его шрифта задается через Control Panel (константа clBtnText). Этот
цвет по умолчанию черный и может меняться при выборе пользователем той
или иной цветовой схемы. У компонента ТStatusBar и его панелей есть возможность
"owner-draw" - программной перерисовки, которая позволяет выводить на панель
текст любого цвета. Измените свойство Style компонента TStatusBar.Panels
на OwnerDraw.

Пример:

procedure TForm1.StatusBar1DrawPanel(StatusBar: TStatusBar; Panel: TStatusPanel;
        const Rect: TRect);
begin
        if Panel = StatusBar.Panels[0] then
        begin
        StatusBar.Canvas.Font.Color := clRed;
        StatusBar.Canvas.TextOut(Rect.Left, Rect.Top, 'Panel - 0')
        end
        else
        begin
        StatusBar.Canvas.Font.Color := clGreen;
        StatusBar.Canvas.TextOut(Rect.Left, Rect.Top, 'Panel - 1');
        end;
end;


Наверх к содержанию

Вопрос:

Как бы мне создать эдакий trackbar в котором вместо широкой белой полоски
с ползунком была бы тонкая линия?

Ответ:

В примере создается компонент, унаследованный от TTrackbar который переопределяет
метод CreateParams и убират флаг TBS_ENABLESELRANGE из Style. Константа
TBS_ENABLESELRANGE обьявленна в модуле CommCtrl.

Пример:

uses CommCtrl, ComCtrls;

type TMyTrackBar = class(TTrackBar)
        procedure CreateParams(var Params: TCreateParams); override;
end;

procedure TMyTrackBar.CreateParams(var Params: TCreateParams);
begin
        inherited;
        Params.Style := Params.Style and not TBS_ENABLESELRANGE;
end;

var
        MyTrackbar : TMyTrackbar;

procedure TForm1.Button1Click(Sender: TObject);
begin
        MyTrackBar := TMyTrackbar.Create(Form1);
        MyTrackbar.Parent := Form1;
        MyTrackbar.Left := 100;
        MyTrackbar.Top := 100;
        MyTrackbar.Width := 150;
        MyTrackbar.Height := 45;
        MyTrackBar.Visible := true;
end;


Наверх к содержанию

Вопрос:

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

Ответ:

Создайте Bitmap и используйте свойство canvas класса TBitmap. Пример создает
Bitmap, рисует на его canvas'е, выводит этот canvas на форму и освобождает
bitmap.

Пример:

procedure TForm1.Button1Click(Sender: TObject);
var
        bm : TBitmap;
begin
        bm := TBitmap.Create;
        bm.Width := 100;
        bm.Height := 100;
        bm.Canvas.Brush.Color := clRed;
        bm.Canvas.FillRect(Rect(0, 0, 100, 100));
        bm.Canvas.MoveTo(0, 0);
        bm.Canvas.LineTo(100, 100);
        Form1.Canvas.StretchDraw(Form1.ClientRect,Bm);
        bm.Free;
end;


Наверх к содержанию

Вопрос:

В некоторых видео режимах прозрачная часть glyph'а стандартного TBitBtn
становится видной. Как этого избежать?

Ответ:

В примере используется техника закраски прозрачной части glyph'а цветом
кнопки на которой он находится - таким образом glyph кажется прозрачным.

Пример:

function InitStdBitBtn(BitBtn : TBitBtn; kind : TBitBtnKind) : bool;
var
        Bm1 : TBitmap;
        Bm2 : TBitmap;
begin
        Result := false;
        if Kind = bkCustom then exit;
        Bm1 := TBitmap.Create;
        case Kind of
        bkOK : Bm1.Handle := LoadBitmap(hInstance, 'BBOK');
        bkCancel : Bm1.Handle := LoadBitmap(hInstance, 'BBCANCEL');
        bkHelp : Bm1.Handle := LoadBitmap(hInstance, 'BBHELP');
        bkYes : Bm1.Handle := LoadBitmap(hInstance, 'BBYES');
        bkNo : Bm1.Handle := LoadBitmap(hInstance, 'BBNO');
        bkClose : Bm1.Handle := LoadBitmap(hInstance, 'BBCLOSE');
        bkAbort : Bm1.Handle := LoadBitmap(hInstance, 'BBABORT');
        bkRetry : Bm1.Handle := LoadBitmap(hInstance, 'BBRETRY');
        bkIgnore : Bm1.Handle := LoadBitmap(hInstance, 'BBIGNORE');
        bkAll : Bm1.Handle := LoadBitmap(hInstance, 'BBALL');

        end;
        Bm2 := TBitmap.Create;
        Bm2.Width := Bm1.Width;
        Bm2.Height := Bm1.Height;
        Bm2.Canvas.Brush.Color := ClBtnFace;
        Bm2.Canvas.BrushCopy(Rect(0, 0, bm2.Width, bm2.Height), Bm1,
        Rect(0, 0, Bm1.width, Bm1.Height),
        Bm1.canvas.pixels[0,0]);
        Bm1.Free;
        LockWindowUpdate(BitBtn.Parent.Handle);
        BitBtn.Kind := kind;
        BitBtn.Glyph.Assign(bm2);
        LockWindowUpdate(0);
        Bm2.Free;
        Result := true;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
        InitStdBitBtn(BitBtn1, bkOk);
end;


Наверх к содержанию

Вопрос:
Создание PolyPolygon используя массив точек?

Ответ:

Polygon - метод компонента TCanvas получает в качестве параметра динамический
массив точек. Функция PolyPolygon() из Windows GDI получает указатель на
массив точек.

Пример:

procedure TForm1.Button1Click(Sender: TObject);
var
        ptArray : array[0..9] of TPOINT;
        PtCounts : array[0..1] of integer;
begin
        PtArray[0] := Point(0, 0);
        PtArray[1] := Point(0, 100);
        PtArray[2] := Point(100, 100);
        PtArray[3] := Point(100, 0);
        PtArray[4] := Point(0, 0);
        PtCounts[0] := 5;
        PtArray[5] := Point(25, 25);
        PtArray[6] := Point(25, 75);
        PtArray[7] := Point(75, 75);
        PtArray[8] := Point(75, 25);
        PtArray[9] := Point(25, 25);
        PtCounts[1] := 5;
        PolyPolygon(Form1.Canvas.Handle,
        PtArray,PtCounts,2);
end;


Наверх к содержанию

Вопрос:

Как создать невизуальный компонент без иконоки, которая изображается в
палитре компонентов в "design-time" (вроде TField)?

Ответ:

Невизуальные компоненты без иконоки удобны для субкомпонентов, связанных
с какими-то другими компонентами. Создайте компонент как обычно, но используйте
RegisterNoIcon вместо RegisterComponent.

Наверх к содержанию

Вопрос:

Как показывать нестандартный встроенный редактор (inplace editor) в ячейке
stringgrid (например combobox).

Ответ:
См. пример

Пример:

procedure TForm1.FormCreate(Sender: TObject);
begin
        {Высоту combobox'а не изменишь, так что вместо combobox'а
        будем изменять высоту строки grid'а !}
        StringGrid1.DefaultRowHeight := ComboBox1.Height;
        {Спрятать combobox}
        ComboBox1.Visible := False;
        ComboBox1.Items.Add('Delphi Kingdom');
        ComboBox1.Items.Add('Королевство Дельфи');
end;

procedure TForm1.ComboBox1Change(Sender: TObject);
begin
        {Перебросим выбранное в значение из ComboBox в grid}
        StringGrid1.Cells[StringGrid1.Col,
        StringGrid1.Row] :=ComboBox1.Items[ComboBox1.ItemIndex];
        ComboBox1.Visible := False;
        StringGrid1.SetFocus;
end;

procedure TForm1.ComboBox1Exit(Sender: TObject);
begin
        {Перебросим выбранное в значение из ComboBox в grid}
        StringGrid1.Cells[StringGrid1.Col,
        StringGrid1.Row] :=ComboBox1.Items[ComboBox1.ItemIndex];
        ComboBox1.Visible := False;
        StringGrid1.SetFocus;
end;

procedure TForm1.StringGrid1SelectCell(Sender: TObject; ACol,
        ARow: Integer; var CanSelect: Boolean);
var
        R: TRect;
begin
        if ((ACol = 3) AND (ARow <> 0)) then
        begin
        {Ширина и положение ComboBox должно соответствовать
        ячейке StringGrid}
        R := StringGrid1.CellRect(ACol, ARow);
        R.Left := R.Left + StringGrid1.Left;
        R.Right := R.Right + StringGrid1.Left;
        R.Top := R.Top + StringGrid1.Top;
        R.Bottom := R.Bottom + StringGrid1.Top;
        ComboBox1.Left := R.Left + 1;
        ComboBox1.Top := R.Top + 1;
        ComboBox1.Width := (R.Right + 1) - R.Left;
        ComboBox1.Height := (R.Bottom + 1) - R.Top;
        {Покажем combobox}
        ComboBox1.Visible := True;
        ComboBox1.SetFocus;
        end;
        CanSelect := True;
end;


Наверх к содержанию

Вопрос:

События KeyPress и KeyDown не вызываются для клавиши Tab - как определить,
что она была нажата?

Ответ:

На уровне формы клавиша tab обычно обрабатывается Windows. В примере создается
обработчик события CM_Dialog для перехвата Dialog keys.

Пример:

type
        TForm1 = class(TForm)
        private
        procedure CMDialogKey( Var msg: TCMDialogKey );
        message CM_DIALOGKEY;
end;

var
        Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.CMDialogKey(var msg: TCMDialogKey);
begin
        if msg.Charcode <> VK_TAB then
        inherited;
end;

procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
        if Key = VK_TAB then
        Form1.Caption := 'Tab Key Down!';
end;


Наверх к содержанию

Вопрос:
В чем отличие между Create(Self) и Create(Application)?

Ответ:

Self может быть использовано только в методе класса, и ссылается на текущий
экземпляр класса. Таким образом "Self" в методе класса TForm1 ссылается
на текущий экземпляр TForm1. При создании компонента Вы передаете его владельца
(owner) в конструктор. При уничтожении формы или компонента автоматически
уничтожаются и все компоненты владельцем которого она является. Таким образом
если при создании формы передать в качестве владельца Application эта форма
будет автоматически уничтожена при уничтожении Application. Если же при
создании формы передать в качестве владельца другую форму, вновь созданная
форма будет автоматически уничтоженна при уничтожении формы-владельца.

Наверх к содержанию

Вопрос:
Как во время выполнения определить поддерживает ли обьект заданное свойство?

Ответ:
function HasProperty(Obj : TObject; Prop : string) : PPropInfo;
begin
        Result := GetPropInfo(Obj.ClassInfo, Prop);
end;

procedure TForm1.Button1Click(Sender: TObject);
var
        p : pointer;
begin
        p :=  HasProperty(Button1, 'Color');
        if p <> nil then
        SetOrdProp(Button1, p, clRed)
        else
        ShowMessage('Button has no color property');
        p :=  HasProperty(Label1, 'Color');
        if p <> nil then
        SetOrdProp(Label1, p, clRed)
        else
        ShowMessage('Label has no color property');
        p :=  HasProperty(Label1.Font, 'Color');
        if p <> nil then
        SetOrdProp(Label1.Font.Color, p, clBlue)
        else
        ShowMessage('Label.Font has no color property');
end;


Наверх к содержанию

Вопрос:
Можно ли рисовать на рамке формы?

Ответ:
Обрабатывайте событие WM_NCPAINT. В примере рамка обводится красной линией
толщиной в 1 пиксел.

Пример:

type
        TForm1 = class(TForm)
        private
        {Private declarations}
        procedure WMNCPaint(var Msg : TWMNCPaint); message WM_NCPAINT;
        public
        {Public declarations}
end;

var
        Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.WMNCPaint(var Msg: TWMNCPaint);
var
        dc : hDc;
        Pen : hPen;
        OldPen : hPen;
        OldBrush : hBrush;
begin
        inherited;
        dc := GetWindowDC(Handle);
        msg.Result := 1;
        Pen := CreatePen(PS_SOLID, 1, RGB(255, 0, 0));
        OldPen := SelectObject(dc, Pen);
        OldBrush := SelectObject(dc, GetStockObject(NULL_BRUSH));
        Rectangle(dc, 0,0, Form1.Width, Form1.Height);
        SelectObject(dc, OldBrush);
        SelectObject(dc, OldPen);
        DeleteObject(Pen);
        ReleaseDC(Handle, Canvas.Handle);
end;


Наверх к содержанию

Вопрос:

Как выполнить какой-то процесс тогда, когда пользователь не работает с моим приложением?

Ответ:
Создайте процедуру, которая будет вызываться при событии Application.OnIdle.

Обьявим процедуру:
{Private declarations}
procedure IdleEventHandler(Sender: TObject; var Done: Boolean);

В разделе implementation опишем поцедуру:

procedure TForm1.IdleEventHandler(Sender: TObject; var Done: Boolean);
begin
        {Do a small bit of work here}
        Done := false;
end;

В методе Form'ы OnCreate - укажем что наша процедура вызывается на событии 
Application.OnIdle.

Application.OnIdle := IdleEventHandler;

Событие OnIdle возникает один раз - когда приложение переходит в режим
"безделья" (idle). Если в обработчике переменной Done присвоить False событие
будет вызываться вновь и вновь, до тех пор пока приложение "бездельничает"
и переменной Done не присвоенно значение True.

Наверх к содержанию

Вопрос:

При перемещении фокуса ввода клавишей Tab чтобы переместить его в RadioGroup
нужно нажать клавишу Tab дважды если какой нибудь пункт RadioGroup уже
выбран, но только один раз если не выбран. Можно ли сделать поведение RadioGroup
логичным?

Ответ:

Установка свойства RadioGroup'ы TabStop в false должна решить эту проблему
- поскольку клавиша tab будет продолжать работать - перемещаясь сразу на
выделенный пункт RadioGroup.

Наверх к содержанию

Вопрос:
Как разместить маленькие картинки в компоненте TPopUpMenu?

Ответ:

В приведенном примере показано как это сделать с использованием функции
Windows API SetMenuItemBitmaps(). Эта функция получает handle popup menu,
позицию строчки меню куда будет помещена картинка, и два дескриптора(handles)
на две картинки (одна из них - картинка которая будет показана когда строка
меню доступна, вторая - когда строка меню недоступна).

type
        TForm1 = class(TForm)
        PopupMenu1: TPopupMenu;
        Pop11: TMenuItem;
        Pop21: TMenuItem;
        Pop31: TMenuItem;
        procedure FormCreate(Sender: TObject);
        procedure FormDestroy(Sender: TObject);
        procedure FormMouseUp(Sender: TObject; Button: TMouseButton;
        Shift: TShiftState; X, Y: Integer);
        private
        {Private declarations}
        bmUnChecked : TBitmap;
        bmChecked : TBitmap;
        public
        {Public declarations}
end;

var
        Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
        bmUnChecked := TBitmap.Create;
        bmUnChecked.LoadFromFile('C:\Program Files\Borland\BitBtns\ALARMRNG.BMP');
        bmChecked := TBitmap.Create;
        bmChecked.LoadFromFile('C:\Program Files\Borland\BitBtns\CHECK.BMP');
        {Add the bitmaps to the item at index 1 in PopUpMenu}
        SetMenuItemBitmaps(PopUpMenu1.Handle,1,MF_BYPOSITION,BmUnChecked.Handle,
        BmChecked.Handle);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
        bmUnChecked.Free;
        bmChecked.Free;
end;

procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
        Shift: TShiftState; X, Y: Integer);
var
        pt : TPoint;
begin
        pt := ClientToScreen(Point(x, y));
        PopUpMenu1.Popup(pt.x, pt.y);
end;


Наверх к содержанию

Вопрос:
Как изменить число фиксированных колонок в TDbGrid?

Пример:

procedure TForm1.Button1Click(Sender: TObject);
begin
        TStringGrid(DbGrid1).FixedCols := 2;
end;


Наверх к содержанию

Вопрос:

Некоторые компоненты баз данных (и среди них TDBGrid) никак не меняют визуальных
свойств, когда к ним отключен доступ (disabled). Как это изменить програмно?

Ответ:

Ниже приведен пример, меняющий цвет шрифта на clGray, когда доступ к элементу
управления (в данном случае TDBGrid) запрещен (disabled).

procedure TForm1.Button1Click(Sender: TObject);
begin
        DbGrid1.Enabled := false;
        DbGrid1.Font.Color := clGray;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
        DbGrid1.Enabled := true;
        DbGrid1.Font.Color := clBlack;
end;


Наверх к содержанию

Вопрос:
Как определить нажаты ли клавиши Shift, Alt, or Ctrl в какой-либо момент времени?

Ответ:

В приведенном примере показано как определить нажата ли клавиша Shift при
выборе строчки меню. Пример также содержит функции проверки состояния клавиш
Alt, Ctrl.

Пример:

function CtrlDown : Boolean;
var
        State : TKeyboardState;
begin
        GetKeyboardState(State);
        Result := ((State[vk_Control] And 128) <> 0);
end;

function ShiftDown : Boolean;
var
        State : TKeyboardState;
begin
        GetKeyboardState(State);
        Result := ((State[vk_Shift] and 128) <> 0);
end;

function AltDown : Boolean;
var
        State : TKeyboardState;
begin
        GetKeyboardState(State);
        Result := ((State[vk_Menu] and 128) <> 0);
end;
procedure TForm1.MenuItem12Click(Sender: TObject);
begin
        if ShiftDown then
        Form1.Caption := 'Shift'
        else    
        Form1.Caption := '';
end;

Наверх к содержанию

Вопрос:
Как изменить шрифта hint'а?

Ответ:
В примере перехватывается событие Application.OnShowHint и изменяется шрифт Hint'а.

Пример:

type
        TForm1 = class(TForm)
        procedure FormCreate(Sender: TObject);
        private
        {Private declarations}
        public
        procedure MyShowHint(var HintStr: string;
        var CanShow: Boolean;var HintInfo: THintInfo);
        {Public declarations}
end;

var
        Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.MyShowHint(var HintStr: string; var CanShow: Boolean;
        var HintInfo: THintInfo);
var
        i : integer;
begin
        for i := 0 to Application.ComponentCount - 1 do
        if Application.Components[i] is THintWindow then
        with THintWindow(Application.Components[i]).Canvas do
        begin
        Font.Name:= 'Arial';
        Font.Size:= 18;
        Font.Style:= [fsBold];
        HintInfo.HintColor:= clWhite;
        end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
        Application.OnShowHint := MyShowHint;
end;


Наверх к содержанию

Вопрос:
Я загружаю TImageList динамически. Как сделать картинки из TImageList прозрачными?

Ответ:
См. ответ.
 
Пример:

procedure TForm1.Button1Click(Sender: TObject);
var
        bm : TBitmap;
        il : TImageList;
begin
        bm := TBitmap.Create;
        bm.LoadFromFile('C:\DownLoad\TEST.BMP');
        il := TImageList.CreateSize(bm.Width,bm.Height);
        il.DrawingStyle := dsTransparent;
        il.Masked := true;
        il.AddMasked(bm, clRed);
        il.Draw(Form1.Canvas, 0, 0, 0);
        bm.Free;
        il.Free;
end;


Наверх к содержанию

Вопрос:

При выполнении диалога FontDialog со свойством Device равным fdBoth or
fdPrinter, появляется ошибка "There are no fonts installed".

Ответ:

Эти установки должны показать шрифты совместимые либо с принтером либо
с экраном. В примере диалог Windows ChooseFont вызывается напрямую чтобы
показать список шрифтов, совместимых одновременно и с экраном и с принтером.

Пример:

uses Printers, CommDlg;

procedure TForm1.Button1Click(Sender: TObject);
var
        cf : TChooseFont;
        lf : TLogFont;
        tf : TFont;
begin
        if PrintDialog1.Execute then
        begin
        GetObject(Form1.Canvas.Font.Handle, sizeof(lf),@lf);
        FillChar(cf, sizeof(cf), #0);
        cf.lStructSize := sizeof(cf);
        cf.hWndOwner := Form1.Handle;
        cf.hdc := Printer.Handle;
        cf.lpLogFont := @lf;
        cf.iPointSize := Form1.Canvas.Font.Size * 10;
        cf.Flags := CF_BOTH or CF_INITTOLOGFONTSTRUCT or
        CF_EFFECTS or CF_SCALABLEONLY or CF_WYSIWYG;
        cf.rgbColors := Form1.Canvas.Font.Color;
        if ChooseFont(cf) <> false then
        begin
        tf := TFont.Create;
        tf.Handle := CreateFontIndirect(lf);
        tf.COlor := cf.RgbColors;
        Form1.Canvas.Font.Assign(tf);
        tf.Free;
        Form1.Canvas.TextOut(10, 10, 'Test');
        end;
        end;
end;


Наверх к содержанию

Вопрос:
Как убрать кнопку с названием моей программы из Панели Задач(Taskbar)?

Ответ:

Отредактируйте файл-проекта (View -> Project Source) Добавьте модуль Windows
в раздел uses. Application.ShowMainForm := False; в строку после "Application.Initialize;".
Добавьте ShowWindow(Application.Handle, SW_HIDE); в строку перед "Application.Run;"

Ваш файл проекта должен выглядеть приблизительно так:

program Project1;

uses
        Windows,
        Forms,
        Unit1 in 'Unit1.pas' {Form1},
        Unit2 in 'Unit2.pas' {Form2};

{$R *.RES}

begin
        Application.Initialize;
        Application.ShowMainForm := False;
        Application.CreateForm(TForm1, Form1);
        Application.CreateForm(TForm2, Form2);
        ShowWindow(Application.Handle, SW_HIDE);
        Application.Run;
end.

В разделе "initialization" (в самом низу) каждого unit'а добавьте

begin
        ShowWindow(Application.Handle, SW_HIDE);
end.


Наверх к содержанию

Вопрос:
Как преобразовать цвета в строку - название цвета  VCL?

Ответ:

Модуль graphics.pas содержит функцию ColorToString() которое преобразует
допустимое значение TColor в его строковое представление используя либо
константу-название цвета (по возможности) либо шестнадцатиричную строку.
Обратная функция - StringToColor()

Пример: 

procedure TForm1.Button1Click(Sender: TObject);
begin
        Memo1.Lines.Add(ColorToString(clRed));
        Memo1.Lines.Add(IntToStr(StringToColor('clRed')));
end;


Наверх к содержанию

Вопрос:

При показе максимизированное формы она перекрывает task bar и не выравнивается
по верху экрана. В чем тут дело?

Ответ:
Это может произойти когда свойство position формы установленно в poScreenCenter.
Установите position = poDefault.


Наверх к содержанию

Вопрос:
Как заставить TEdit не 'пикать' при нажатии недопустимых клавиш?

Ответ:
Перехватите событие KeyPress и установите key = #0 для недопустимых клавиш.

Пример:

procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);
begin
        if ((UpCase(Key) < 'A') or (UpCase(Key) > 'Z')) then
        Key := #0;
end;


Наверх к содержанию

Вопрос:
Как получить число и список всех компонентов, расположенных на TNoteBook?

Ответ: 
В примере список выводится на Listbox.

Пример:

procedure TForm1.Button1Click(Sender: TObject);
var
        n: integer;
        p: integer;
begin
        ListBox1.Clear;
        with Notebook1 do
        begin
        for n := 0 to ControlCount - 1 do
        begin
        with TPage(Controls[n]) do
        begin
        ListBox1.Items.Add('Notebook Page: ' +
        TPage(Notebook1.Controls[n]).Caption);
        for p := 0 to ControlCount - 1 do
        ListBox1.Items.Add(Controls[p].Name);
        ListBox1.Items.Add(EmptyStr);
        end;
        end;
        end;
end;


Наверх к содержанию

Вопрос:

Я хочу вставить escape code в строку при использовании функции Format().
Например, я хочу создать строку, содержащую символ табуляции. В "C" я бы
написал что-то вроде sprintf(buffer, "%s\t%s", str);. А как это будет на
Pascal'e?

Ответ:

Функция Format Pascal'я не использует escape codes. Вместо этого нужно
вставить в строку действительное значение символа в кодировке ASCII.

Пример:

Buffer := Format('%s'#9'%s', [Str1, Str2]);
ShowMessage(Format('%s'#9'%s', ['Column1', 'Column2']));


Наверх к содержанию

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

Ответ:
Перехватите F2 на событии keydown.

Пример:

procedure TForm1.ListView1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
        if Ord(Key) = VK_F2 then
        ListView1.Selected.EditCaption;
end;


Наверх к содержанию

Вопрос:
Когда я добавляю обьект в список TStrings как мне его потом уничтожить?

Ответ:
Просто вызовите метод free этого обьекта.

Пример:

procedure TForm1.FormCreate(Sender: TObject);
var
        Icon: TIcon;
begin
        Icon := TIcon.Create;
        Icon.LoadFromFile('C:\Program Files\BorlandImages\CONSTRUC.ICO');
        ListBox1.Items.AddObject('Item 0', Icon);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
        ListBox1.Items.Objects[0].Free;
end;


Наверх к содержанию

Вопрос:
Вместо печати графики я хочу использовать резидентный шрифт принтера. Как?

Ответ:

Используте функцию Windows API - GetStockObject() чтобы получить дескриптор
(handle) шрифта по умолчанию устройства (DEVICE_DEFAULT_FONT) и передайте
его Printer.Font.Handle.

Пример:

uses Printers;

procedure TForm1.Button1Click(Sender: TObject);
var
        tm : TTextMetric;
        i : integer;
begin
        if PrintDialog1.Execute then
        begin
        Printer.BeginDoc;
        Printer.Canvas.Font.Handle := GetStockObject(DEVICE_DEFAULT_FONT);
        GetTextMetrics(Printer.Canvas.Handle, tm);
        for i := 1 to 10 do
        begin
        Printer.Canvas.TextOut(100,i * tm.tmHeight +
        tm.tmExternalLeading,'Test');
        end;
        Printer.EndDoc;
        end;
end;


Наверх к содержанию

Вопрос:
Как получить строку сообщения об ошибке Windows код которой получен функцией
GetLastError?

Ответ:
Функция RTL SysErrorMessage(GetLastError).

Пример:

procedure TForm1.Button1Click(Sender: TObject);
begin
        {Cause a Windows system error message to be logged}
        ShowMessage(IntToStr(lStrLen(nil)));
        ShowMessage(SysErrorMessage(GetLastError));
end;


Наверх к содержанию

Вопрос:

Как заставить Delphi выполнять еще более строгую проверка типов? Напрмер
- я создаю пользовательский тип, унаследованный от double и могу передавать
его любым функциям, принимающим параметр типа double. Как заставить компилятор
проводить более строгую проверку типов и выдавать предупреждение в таких
случаях?

Ответ:
См. ответ.  

Пример:

type TStrongType = type Double;
type TWeakType = Double;

procedure AddWeakType(var d : TWeakType);
begin
        d := d + 1;
end;

procedure AddStrongType(var d : TStrongType);
begin
        d := d + 1;
end;

procedure AddDoubleType(var d : Double);
begin
        d := d + 1;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
        d : Double;
        s : TStrongType;
        w : TWeakType;
begin
        AddDoubleType(d); {compiles fine}
        AddDoubleType(w); {compiles fine}
        AddDoubleType(s); {<- compile error}
        AddDoubleType(double(s)); {compiles fine}
        AddWeakType(d); {compiles fine}
        AddWeakType(w); {compiles fine}
        AddWeakType(s); {<- compile error}
        AddWeakType(TWeakType(s)); {compiles fine}
        AddStrongType(d); {<- compile error}
        AddStrongType(TStrongType(d)); {compiles fine}
        AddStrongType(w); {<- compile error}
        AddStrongType(TStrongType(w)); {compiles fine}
        AddStrongType(s); {compiles fine}
end;


Наверх к содержанию

Вопрос:
Где в Delphi обьявленны VK_Key для A-Z и 0-9?

Ответ:
Они не обьявлены в Delphi поскольку они просто могуть быть заменены буквами.
VK_0 до VK_9 то же что и  ASCII '0' до '9' ($30 - $39),
VK_A до VK_Z то же что и  ASCII 'A' до 'Z' ($41 - $5A).


Наверх к содержанию

Вопрос: 
Как изменить оконную процедуру для TForm?

Ответ:

Переопределите в подклассе TForm оконную процедуру WinProc класса. В примере
оконная процедура переопределяется для того чтобы реагировать на сообщение
WM_CANCELMODE, показывающее, что выполняется messagebox или какой-либо
еще диалог.

Пример:

type
        TForm1 = class(TForm)
        Button1: TButton;
        procedure WndProc (var Message: TMessage); override;
        procedure Button1Click(Sender: TObject);
        private
        {Private declarations}
        public
        {Public declarations}
end;

var
        Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.WndProc (var Message: TMessage);
begin
        if Message.Msg = WM_CANCELMODE then
        begin
        Form1.Caption := 'A dialog or message box has popped up';
        end
        else
        inherited  // <- остальное сделает родительская процедура
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
        ShowMessage('Test Message');
end;


Наверх к содержанию

Вопрос:
Как узнать размеры TComboBox с показанным выпадающим списком до показа списка?

Ответ:

На событии FormShow пошлите сообщение CB_SHOWDROPDOWN в ComboBox дважды
- один раз чтобы заставить список выпасть, второй - чтобы убрать его. Затем
пошлите сообщение CB_GETDROPPEDCONTROLRECT, передав в качестве параметра
адрес TRect. TRect будет содержать экранные кординаты прямоугольника описывающего
ComboBox вместе с выпавшим списком. Затем Вы можете вызвать ScreenToClient
чтобы преобразовать экранные кординаты в координаты клиентской области
окна.

Пример:

var
        R : TRect;
procedure TForm1.FormShow(Sender: TObject);
var
        T : TPoint;
begin
        SendMessage(ComboBox1.Handle, CB_SHOWDROPDOWN, 1, 0);
        SendMessage(ComboBox1.Handle, CB_SHOWDROPDOWN, 0, 0);
        SendMessage(ComboBox1.Handle, CB_GETDROPPEDCONTROLRECT, 0, LongInt(@r));
        t := ScreenToClient(Point(r.Left, r.Top));
        r.Left := t.x;
        r.Top := t.y;
        t := ScreenToClient(Point(r.Right, r.Bottom));
        r.Right := t.x;
        r.Bottom := t.y;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
        Form1.Canvas.Rectangle(r.Left, r.Top, r.Right, r.Bottom );
end;


Наверх к содержанию

Вопрос:
Я хочу создать в своей программе меню "а ля Дельфи 4". Как это сделать?

Ответ:
1. Разместите на форме TControlBar. (закладка Additional) Установите Align = Client.
2. Разместите TToolBar (закладка Win32) внутри TControlBar.
3. Установите в True свойства Flat и ShowCaptions этого TToolBar.
4. Создайте на TToolBar столько TToolButtons сколько Вам нужно. (щелкнув по TToolBar
правой кнопкой и выбрав NewButton)
5. Установите свойство Grouped = True для всех TToolButtons. Это позволит меню выпадать
при перемещении курсора между главными пунктами меню (если меню уже показано).
6. Разместите на фоме TMainMenu и убедитесь, что оно *НЕ присоденено* как меню главной
формы. (посмотрите свойство Menu формы).
7. Создайте все пункты меню (щелкнув по TMainMenu кнопкой и выбрав Menu Designer)
8. Для каждой TToolButton установите ее MenuItem равным соответсвующему пункту TMainMenu.

Наверх к содержанию

Вопрос:
Как добится того чтобы TMemo и TEdit имели работали не только в режиме вставки символов,
но и в режиме замены?

Ответ:

Элементы управления Windows TEdit и TMemo не имеют режима замены. Однако
этот режим можно эмулировать установив свойство SelLength edit'а или memo
в 1 при обработке события KeyPress. Это заставит его перезаписывать символ
в текущей позиции курсора. В примере этот способ используется для TMemo.
Режим вставка/замена переключается клавишей "Insert".

Пример:

type
        TForm1 = class(TForm)
        Memo1: TMemo;
        procedure Memo1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
        procedure Memo1KeyPress(Sender: TObject; var Key: Char);
private
        {Private declarations}
        InsertOn : bool;
public
        {Public declarations}
end;

var
        Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Memo1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
        if (Key = VK_INSERT) and (Shift = []) then
        InsertOn := not InsertOn;
end;

procedure TForm1.Memo1KeyPress(Sender: TObject; var Key: Char);
begin
        if ((Memo1.SelLength = 0) and (not InsertOn)) then
        Memo1.SelLength := 1;
end;


Наверх к содержанию

Вопрос:
Как отправить сообщение сразу всем элементам управления формы?

Ответ:

Можно использовать Screen.Forms[i].BroadCast(msg); где [i] - индекс той
формы, которой Вы хотите переслать сообщение. BroadCast работает со всеми
компонентами, потомками TWinControls и отправляет сообщение всем дочерним
компонентам из массива Controls. Если один из дочерних компонентов обрабатывает
это сообщение и устанавливает Msg.Result в ненулевое значение - дальнейшая
рассылка сообщения останавливается.

Наверх к содержанию

Вопрос:
При попытке присвоить значение свойству "selected" ListBox'а вырабатывается exception
"Index is out of bounds". В чем тут дело и как присвоить значение свойству selected?

Ответ:
Свойство "selected" компонента ТListBox может быть использованно только если свойство
MultiSelect установленно в True. Если Вы работаете с ListBox'ом у которого
MultiSelect=false то используйте свойство ItemIndex.

Пример:

procedure TForm1.Button1Click(Sender: TObject);
begin
        ListBox1.Items.Add('1');
        ListBox1.Items.Add('2');
        {This will fail on a single selection ListBox}
//      ListBox1.Selected[1] := true;
        ListBox1.ItemIndex := 1; {This is ok}
end;


Наверх к содержанию

Вопрос:
Как ограничить длинну текста, вводимого в TEdit, так чтобы ширина текста не превышала
ширину TEdit'а?

Ответ:

В примере приведено два способа ограничить длинну текста в TEdit так чтобы
она не превышала ширину клиентской области окна TEdit'а и не появлялась
прокрутка текста. Первый способ устанавливает свойство TEdit'а MaxLength
равным числу букв "W", которые поместятся в TEdit. "W" выбрана потому,
что является, наверное, самой широкой буквой в любом шрифте. Этот метод
сносно работает для шрифтов с фиксированной шириной букв, но для шрифтов
с переменной шириной букв вряд ли сгодится. Второй способ перхватывает
событие KeyPress TEdit'а и измеряет ширину уже введенного текста и ширину
нового символа. Если ширина больше чем клиентская область TEdit'а новый
символ отбрасывается и вызывается MessageBeep.

Пример:

procedure TForm1.FormCreate(Sender: TObject);
var
        cRect : TRect;
        bm : TBitmap;
        s : string;
begin
        Windows.GetClientRect(Edit1.Handle, cRect);
        bm := TBitmap.Create;
        bm.Width := cRect.Right;
        bm.Height := cRect.Bottom;
        bm.Canvas.Font := Edit1.Font;
        s := 'W';
        while bm.Canvas.TextWidth(s) < CRect.Right do
        s := s + 'W';
        if length(s) > 1 then
        begin
        Delete(s, 1, 1);
        Edit1.MaxLength := Length(s);
        end;
end;

{Другой вариант}

procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);
var
        cRect : TRect;
        bm : TBitmap;
begin
        if ((Ord(Key) <> VK_TAB) and (Ord(Key) <> VK_RETURN) and
        (Ord(Key) <> VK_LEFT) and (Ord(Key) <> VK_BACK)) then
        begin
        Windows.GetClientRect(Edit1.Handle, cRect);
        bm := TBitmap.Create;
        bm.Width := cRect.Right;
        bm.Height := cRect.Bottom;
        bm.Canvas.Font := Edit1.Font;
        if bm.Canvas.TextWidth(Edit1.Text + Key) > CRect.Right then
        begin
        Key := #0;
        MessageBeep(-1);
        end;
        bm.Free;
        end;
end;


Наверх к содержанию

Вопрос:
  Как перемещать компонент мышкой во время работы программы "runtime"?

Ответ:

Перехватить событие OnMouseDown, запомнить x и y координты курсора мыши.
Отслеживать движение мыши по событию OnMouseMove и перемещать компонент
вслед за курсором мыши до тех пор пока не произойдет событие OnMouseUp.
В примере показано перемещение компонента TButton. Перемещение начинается,
когда пользователь "берет" TButton мышью, удерживая нажатой клавишу "Сontrol".

Пример:

type
        TForm1 = class(TForm)
        Button1: TButton;
        procedure Button1MouseDown(Sender: TObject; Button: TMouseButton;
        Shift: TShiftState; X, Y: Integer);
        procedure Button1MouseMove(Sender: TObject; Shift: TShiftState; X,
        Y: Integer);
        procedure Button1MouseUp(Sender: TObject; Button: 
        TMouseButton; Shift: TShiftState; X, Y: Integer);
        private
        {Private declarations}
        public
        {Public declarations}
        MouseDownSpot : TPoint;
        Capturing : bool;
end;

var
        Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1MouseDown(Sender: TObject; Button: TMouseButton;
        Shift: TShiftState; X, Y: Integer);
begin
        if ssCtrl in Shift then
        begin 
        SetCapture(Button1.Handle);
        Capturing := true;
        MouseDownSpot.X := x;
        MouseDownSpot.Y := Y;
        end;
end;

procedure TForm1.Button1MouseMove(Sender: TObject; Shift: TShiftState; X,  Y: Integer);
begin
        if Capturing then
        begin
        Button1.Left := Button1.Left - (MouseDownSpot.x - x);
        Button1.Top := Button1.Top - (MouseDownSpot.y - y);
        end;
end;

procedure TForm1.Button1MouseUp(Sender: TObject; Button:
        TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
        if Capturing then
        begin
        ReleaseCapture;
        Capturing := false;
        Button1.Left := Button1.Left - (MouseDownSpot.x - x);
        Button1.Top := Button1.Top - (MouseDownSpot.y - y);
        end;
end;


Наверх к содержанию

Вопрос:
При попытке создать обьект класса TPrinter (TPrinter.Create) я получаю exception.
Почему?

Ответ:
В создании обьекта класса TPrinter с использованием TPrinter.Create нет необходимости,
так как обьект класса TPrinter (называемый Printer) автоматически создается при
использовании модуля Printers.

Пример:

uses Printers;

procedure TForm1.Button1Click(Sender: TObject);
begin
        Printer.BeginDoc;
        Printer.Canvas.TextOut(100, 100, 'Hello World!');
        Printer.EndDoc;
end;



Наверх к содержанию

Вопрос:
Как перехватить события в неклиентской области формы, в заголовке окна, например?

Ответ:
Создайте обработчик одного из сообщений WM_NC (non client - не клиентских) (посмотрите
WM_NC в Windows API help). Пример показывает как перехватить вижение мыши во всей
неклиенстской области окна (рамка и заголовок).

Пример:

unit Unit1;

interface

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

type
TForm1 = class(TForm)
private
        {Private declarations}
        procedure WMNCMOUSEMOVE(var Message: TMessage);
        message WM_NCMOUSEMOVE;
public
        {Public declarations}
end;

var
        Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.WMNCMOUSEMOVE(var Message: TMessage);
var
        s : string;

begin
        case Message.wParam of
        HTERROR:        
        s:= 'HTERROR';
        HTTRANSPARENT:
        s:= 'HTTRANSPARENT';
        HTNOWHERE:      
        s:= 'HTNOWHERE';
        HTCLIENT:
        s:= 'HTCLIENT';
        HTCAPTION:
        s:= 'HTCAPTION';
        HTSYSMENU:
        s:= 'HTSYSMENU';
        HTSIZE:
        s:= 'HTSIZE';
        HTMENU:
        s:= 'HTMENU';
        HTHSCROLL:
        s:= 'HTHSCROLL';
        HTVSCROLL:
        s:= 'HTVSCROLL';
        HTMINBUTTON:
        s:= 'HTMINBUTTON';
        HTMAXBUTTON:
        s:= 'HTMAXBUTTON';
        HTLEFT:
        s:= 'HTLEFT';
        HTRIGHT:
        s:= 'HTRIGHT';
        HTTOP:
        s := 'HTTOP';
        HTTOPLEFT:
        s:= 'HTTOPLEFT';
        HTTOPRIGHT:
        s:= 'HTTOPRIGHT';
        HTBOTTOM:
        s:= 'HTBOTTOM';
        HTBOTTOMLEFT:
        s:= 'HTBOTTOMLEFT';
        HTBOTTOMRIGHT:
        s:= 'HTBOTTOMRIGHT';
        HTBORDER:
        s:= 'HTBORDER';
        HTOBJECT:
        s:= 'HTOBJECT';
        HTCLOSE:
        s:= 'HTCLOSE';
        HTHELP:
        s:= 'HTHELP';
        else s:= '';
        end;
        Form1.Caption := s;
        Message.Result := 0;
end;

end.


Наверх к содержанию

Вопрос:
При попытке использовать метод TCanvas.StretchDraw чтобы нарисовать иконку
увеличенной ее размер не изменяется. Что делать?

Ответ: 
Иконки всегда рисуются размером принятым в системе по умолчанию. Чтобы показать
увеличенный вид иконки скоприуйте ее на bitmap, а зате используйте метод
TCanvas.StretchDraw.

Пример:

procedure TForm1.Button1Click(Sender: TObject);
var
        TheBitmap : TBitmap;
begin
        TheBitmap := TBitmap.Create;
        TheBitmap.Width := Application.Icon.Width;
        TheBitmap.Height := Application.Icon.Height;
        TheBitmap.Canvas.Draw(0, 0, Application.Icon);
        Form1.Canvas.StretchDraw(Rect(0,0,TheBitmap.Width * 3,TheBitmap.Height * 3),
   TheBitmap);
        TheBitmap.Free;
end;


Наверх к содержанию

Вопрос:
Можно ли сделать так чтобы TStringGrid автоматически изменял ширину колонок, чтобы
вместить самую длинную строчку в колонке?

Ответ:
См. пример.

Пример:

procedure AutoSizeGridColumn(Grid : TStringGrid; column : integer);
var
        i : integer;
        temp : integer;
        max : integer;
begin
        max := 0;
        for i := 0 to (Grid.RowCount - 1) do
        begin
        temp := Grid.Canvas.TextWidth(grid.cells[column, i]);
        if temp > max then max := temp;
        end;
        Grid.ColWidths[column] := Max + Grid.GridLineWidth + 3;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
        AutoSizeGridColumn(StringGrid1, 1);
end;



Наверх к содержанию

Вопрос:
TTimer работает не достаточно точно. Как получить более высокую точность?

Ответ:

Таймер Windows не был создан с целью получения сверхточного хронометра.
:-( Другими словами, когда Вы устанавливаете таймер на срабатывания каждые
1000 миллисекунд, он может срабатывать через интервал несколько больший
чем 1000 миллисекунд. Значения меньше 55 миллисекунд никогда не будут срабатывать
вовремя в Windows, поскольку это минимальная точность таймера. Можно проверять
системное время и сравнивать его со временем предыдущего события таймера
чтобы повысить точность.

Наверх к содержанию

Вопрос:
Как поместить JPEG-картинку в exe-файл и потом загрузить ее?

Ответ:
1) Создайте текстовый файл с расширением ".rc". Имя этого файла должно отличаться
от имени файла-пректа или любого модуля проекта.
Файл должен содержать строку вроде: MYJPEG JPEG C:\DownLoad\MY.JPG
где:
"MYJPEG" имя ресурса
"JPEG" пользовательский тип ресурса
"C:\DownLoad\MY.JPG" руть к  JPEG файлу.

Пусть например rc-файл называется "foo.rc"

Запустите BRCC32.exe (Borland Resource CommandLine Compiler) - программа находится
в каталоге Bin Delphi/C++ Builder'а - передав ей в качестве параметра полный путь
к rc-файлу.
В нашем примере:

C:\DelphiPath\BIN\BRCC32.EXE  C:\ProjectPath\FOO.RC
Вы получите откомпилированный ресурс - файл с расширением ".res".
(в нашем случает foo.res).
Далее добавте ресурс к своему приложению.

{Грузим ресурс}
{$R FOO.RES}

uses Jpeg;

procedure LoadJPEGFromRes(TheJPEG : string; ThePicture : TPicture);
var
        ResHandle : THandle;
        MemHandle : THandle;
        MemStream : TMemoryStream;
        ResPtr    : PByte;
        ResSize   : Longint;
        JPEGImage : TJPEGImage;
begin
        ResHandle := FindResource(hInstance, PChar(TheJPEG), 'JPEG');
        MemHandle := LoadResource(hInstance, ResHandle);
        ResPtr    := LockResource(MemHandle);
        MemStream := TMemoryStream.Create;
        JPEGImage := TJPEGImage.Create;
        ResSize := SizeOfResource(hInstance, ResHandle);
        MemStream.SetSize(ResSize);
        MemStream.Write(ResPtr^, ResSize);
        FreeResource(MemHandle);
        MemStream.Seek(0, 0);
        JPEGImage.LoadFromStream(MemStream);
        ThePicture.Assign(JPEGImage);
        JPEGImage.Free;
        MemStream.Free;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
        LoadJPEGFromRes('MYJPEG', Image1.Picture);
end;


Наверх к содержанию

Вопрос:
Как перехватить сообщения прокрутки в TScrollBox?

Ответ:
Следующий пример перехватывает сообщения о прокрутке компонента TScrollBox и
синхронизирует обе линейки прокрутки. Сообщения прокрутки перехватываются с помощью
переопределения окнной процедуры (WinProc) ScrollBox'а.

Пример:

type
{$IFDEF WIN32}
        WParameter = LongInt;
{$ELSE}
        WParameter = Word;
{$ENDIF}
        LParameter = LongInt;

{Declare a variable to hold the window procedure we are replacing}
var
        OldWindowProc : Pointer;

function NewWindowProc(WindowHandle : hWnd;
        TheMessage   : WParameter;
        ParamW : WParameter;
        ParamL : LParameter) : LongInt
{$IFDEF WIN32} stdcall; {$ELSE} ; export; {$ENDIF}
var
        TheRangeMin : integer;
        TheRangeMax : integer;
        TheRange : integer;
begin
        if TheMessage = WM_VSCROLL then
        begin
        {Get the min and max range of the horizontal scroll box}
        GetScrollRange(WindowHandle, SB_HORZ, TheRangeMin, TheRangeMax);
        {Get the vertical scroll box position}
        TheRange := GetScrollPos(WindowHandle, SB_VERT);
        {Make sure we wont exceed the range}
        if TheRange < TheRangeMin then
        TheRange := TheRangeMin else
        if TheRange > TheRangeMax then
        TheRange := TheRangeMax;
        {Set the horizontal scroll bar}
        SetScrollPos(WindowHandle, SB_HORZ, TheRange, true);
        end;
        if TheMessage = WM_HSCROLL then
        begin
        {Get the min and max range of the horizontal scroll box}
        GetScrollRange(WindowHandle, SB_VERT, heRangeMin, TheRangeMax);
        {Get the horizontal scroll box position}
        TheRange := GetScrollPos(WindowHandle, SB_HORZ);
        {Make sure we wont exceed the range}
        if TheRange < TheRangeMin then
        TheRange := TheRangeMin
        else
        if TheRange > TheRangeMax then
        TheRange := TheRangeMax;
        {Set the vertical scroll bar}
        SetScrollPos(WindowHandle, SB_VERT, TheRange, true);
        end;

        {Call the old Window procedure to allow processing of the message.}
        NewWindowProc := CallWindowProc(OldWindowProc, WindowHandle, TheMessage,
        ParamW, ParamL);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
        {Set the new window procedure for the control and remember 
        the old window procedure.}
        OldWindowProc := Pointer(SetWindowLong(ScrollBox1.Handle, GWL_WNDPROC,
        LongInt(@NewWindowProc)));
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
        {Set the window procedure back to the old window procedure.}
        SetWindowLong(ScrollBox1.Handle, GWL_WNDPROC, LongInt(OldWindowProc));
end;


Наверх к содержанию

Вопрос:
Как сделать прямоугольник для выделения части картинки для редактирования?

Ответ:

Самый простой способ - воспользоваться функцией Windows API DrawFocusRect.
Функция DrawFocusRect использует операцию XOR при рисовании - таким образом
вывод прямоугольника дважды с одними и теми же координатами стирает прямоугольник,
и прямоугольник всегда будет виден, на фоне какого бы цвета он не выводился.

Пример:

type
        TForm1 = class(TForm)
        procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
        Shift: TShiftState; X, Y: Integer);
        procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X,
        Y: Integer);
        procedure FormMouseUp(Sender: TObject; Button: TMouseButton;
        Shift: TShiftState; X, Y: Integer);
        private
        {Private declarations}
        Capturing : bool;
        Captured : bool;
        StartPlace : TPoint;
        EndPlace : TPoint;
        public
        {Public declarations}
end;

var
        Form1: TForm1;

implementation

{$R *.DFM}

function MakeRect(Pt1 : TPoint; Pt2 : TPoint) : TRect;
begin
        if pt1.x < pt2.x then
        begin
        Result.Left := pt1.x;
        Result.Right := pt2.x;
        end
        else
        begin
        Result.Left := pt2.x;
        Result.Right := pt1.x;
        end;
        if pt1.y < pt2.y then
        begin
        Result.Top := pt1.y;
        Result.Bottom := pt2.y;
        end
        else
        begin
        Result.Top := pt2.y;
        Result.Bottom := pt1.y;
        end;
end;

procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
        Shift: TShiftState; X, Y: Integer);
begin
        if Captured then
        DrawFocusRect(Form1.Canvas.Handle,MakeRect(StartPlace,EndPlace));
        StartPlace.x := X;
        StartPlace.y := Y;
        EndPlace.x := X;
        EndPlace.y := Y;
        DrawFocusRect(Form1.Canvas.Handle,MakeRect(StartPlace,EndPlace));
        Capturing := true;
        Captured := true;
end;

procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
        Y: Integer);
begin
        if Capturing then
        begin
        DrawFocusRect(Form1.Canvas.Handle,MakeRect(StartPlace,EndPlace));
        EndPlace.x := X;
        EndPlace.y := Y;
        DrawFocusRect(Form1.Canvas.Handle,MakeRect(StartPlace,EndPlace));
        end;
end;

procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
        Shift: TShiftState; X, Y: Integer);
begin
        Capturing := false;
end;


Наверх к содержанию

Вопрос:
Можно ли использовать иконку как картинку на кнопке TSpeedButton?

Ответ:
Можно. См. пример.

Пример:

uses ShellApi;

procedure TForm1.FormShow(Sender: TObject);
var
        Icon: TIcon;
begin
        Icon := TIcon.Create;
        Icon.Handle := ExtractIcon(0,'C:\WINDOWS\NOTEPAD.EXE',1);
        SpeedButton1.Glyph.Width := Icon.Width;
        SpeedButton1.Glyph.Height := Icon.Height;
        SpeedButton1.Glyph.Canvas.Draw(0, 0, Icon);
        Icon.Free;
end;


Наверх к содержанию

Вопрос:
Как поместить прозрачную фоновую каринку на компонент CoolBar?

Ответ:
procedure TForm1.Button1Click(Sender: TObject);
var
        Bm1 : TBitmap;
        Bm2 : TBitmap;
begin
        Bm1 := TBitmap.Create;
        Bm2 := TBitmap.Create;
        Bm1.LoadFromFile('c:\download\test.bmp');
        Bm2.Width := Bm1.Width;
        Bm2.Height := Bm1.Height;
        bm2.Canvas.Brush.Color := CoolBar1.Color;
        bm2.Canvas.BrushCopy(Rect(0, 0, bm2.Width, bm2.Height), Bm1,
        Rect(0, 0, Bm1.width, Bm1.Height), ClWhite);
        bm1.Free;
        CoolBar1.Bitmap.Assign(bm2);
        bm2.Free;
end;


Наверх к содержанию

Вопрос:
Ползунок компонента TScrollBar все время мигает. Как это отключить?

Ответ:
Установите свойтсво ScrollBar.TabStop в False.


Наверх к содержанию

Вопрос:
Как программно перевести DBgrid в реим редактирования и установить курсор в
окошке редактирования в требуемую позицию?

Ответ:

Переведите таблицу в режим редактирования, затем получите дескриптор (handle)
окна редактирования и перешлите ей сообщение EM_SETSEL. В качестве параметров
вы должны переслать начальную позицию курсора, и конечную позицию, определяющую
конец выделения текста цветом. В приведенном примере курсор помещается
во вторую позицию, текст внутри ячейки не выделяется.

Пример:

procedure TForm1.Button1Click(Sender: TObject);
var
        h : THandle;
begin
        Application.ProcessMessages;
        DbGrid1.SetFocus;
        DbGrid1.EditorMode := true;
        Application.ProcessMessages;
        h:= Windows.GetFocus;
        SendMessage(h, EM_SETSEL, 2, 2);
end;

Наверх к содержанию



Вопрос:

Как поместить курсор в определенную позицию edit'а и подобных ему элементов
управления?

Ответ:
Можно использовать методы Delphi SelStart() и SelectLength().

Пример:

procedure TForm1.Button1Click(Sender: TObject);
begin
        Edit1.SetFocus;
        {переводим курсор во вторую позицию}
        Edit1.SelStart := 2;
        {не выделяем никакого текста}
        Edit1.SelLength := 0;
end;

Наверх к содержанию



Вопрос:

Как среагировать на минимизацию-максимизацию формы перед тем как произойдет
изменение

размера формы?

Ответ:
В примере перехватывается сообщение WM_SYSCOMMAND. Если это сообщение говорит о
минимизации или максимизации формы - пищит динамик.

Пример:

type
        TForm1 = class(TForm)
        private
        {Private declarations}
        procedure WMSysCommand(var Msg: TWMSysCommand);
        message WM_SYSCOMMAND;
        public
        {Public declarations}
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.WMSysCommand;
begin
        if (Msg.CmdType = SC_MINIMIZE) or (Msg.CmdType = SC_MAXIMIZE) then
        MessageBeep(0)
        else
        inherited;
end;

Наверх к содержанию



Вопрос:

Можно ли сделать так - одна форма показывает другую и остается позади
нее, но фокус

ввода не переходит к новой форме, а остается у старой?

Ответ:
В примере показывается не автосоздаваемая (non auto-created) форма, но фокус ввода ей
не передается.

Пример:

uses Unit2;

procedure TForm1.Button1Click(Sender: TObject);
begin
        Form2 := TForm2.Create(Application);
        Form2.Visible := FALSE;
        ShowWindow(Form2.Handle, SW_SHOWNA);
end;

Наверх к содержанию



Вопрос:

На некоторых laptop компьютерах может не быть флоппи дисковода. Можно
ли удалять

из списка TDriveComboBox диски которые отключены?

Ответ:
В примере TDriveComboBox не показывает дисководы, которые не готовы. (not ready).
Учтите что на многих компьютерах будет ощутимая задержка при поверке plug&play
флоппи дисковода.

Пример:

procedure TForm1.FormCreate(Sender: TObject);
var
        i : integer;
        OldErrorMode : Word;
        OldDirectory : string;
begin
        OldErrorMode := SetErrorMode(SEM_NOOPENFILEERRORBOX);
        GetDir(0, OldDirectory);
        i := 0;
        while i <= DriveComboBox1.Items.Count - 1 do begin
        {$I-}
        ChDir(DriveComboBox1.Items[i][1] + ':\');
        {$I+}
        if IoResult <> 0 then
        DriveComboBox1.Items.Delete(i)
        else
        inc(i);
        end;
        ChDir(OldDirectory);
        SetErrorMode(OldErrorMode);
end;

Наверх к содержанию



Вопрос:

Как сообщить всем формам моего приложения (в том числе и не видимым
в данный момент)

об изминении каких-то глобальных значений?

Ответ:
Один из способов - создать пользовательское сообщение и использовать метод preform
чтобы разослать его всем формам из массива Screen.Forms.

Пример:

{Code for Unit1}

const
UM_MyGlobalMessage = WM_USER + 1;

type
        TForm1 = class(TForm)
        Label1: TLabel;
        Button1: TButton;
        procedure FormShow(Sender: TObject);
        procedure Button1Click(Sender: TObject);
   private
        {Private declarations}
        procedure UMMyGlobalMessage(var AMessage: TMessage); message
        UM_MyGlobalMessage;
        public
        {Public declarations}
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

uses Unit2;

procedure TForm1.FormShow(Sender: TObject);
begin
Form2.Show;
end;

procedure TForm1.UMMyGlobalMessage(var AMessage: TMessage);
begin
        Label1.Left := AMessage.WParam;
        Label1.Top := AMessage.LParam;
        Form1.Caption := 'Got It!';
end;

procedure TForm1.Button1Click(Sender: TObject);
var
        f: integer;
begin
        for f := 0 to Screen.FormCount - 1 do
        Screen.Forms[f].Perform(UM_MyGlobalMessage, 42, 42);
end;

{Code for Unit2}

const
        UM_MyGlobalMessage = WM_USER + 1;
type
        TForm2 = class(TForm)
        Label1: TLabel;
        private
        {Private declarations}
        procedure UMMyGlobalMessage(var AMessage: TMessage);
        message UM_MyGlobalMessage;
        public
        {Public declarations}
end;

var
Form2: TForm2;

implementation

{$R *.DFM}

procedure TForm2.UMMyGlobalMessage(var AMessage: TMessage);
begin
        Label1.Left := AMessage.WParam;
        Label1.Top := AMessage.LParam;
        Form2.Caption := 'Got It!';
end;

Наверх к содержанию

Как обновить список дисков компонента
TDriveComboBox, учитывая, что могут быть

подключены/отключены сетевые диски и произведена "горячая
замена" plug&play дисков?

Совет взят с диска "All4Delphi" 14.10.2001
Следующий пример вызывает защищенный (protected) метод класса TDriveComboBox
BuildList() для регеирации списка дисков. (использовая так наз. "class cracer")

Пример:

type
TNewDriveComboBox = class(TDriveComboBox) //это наш "class cracer"
end;

procedure TForm1.Button1Click(Sender: TObject);
var
        Drive : char;
begin
        Drive := DriveComboBox1.Drive;
        TNewDriveComboBox(DriveComboBox1).BuildList;
        //вызываем защищенный метод родительского класса
        DriveComboBox1.Drive := Drive;

end;

Наверх к содержанию

Как программно заставить
выпасть меню?

Совет взят с диска "All4Delphi" 15.10.2001
В примере показано как показать меню и выбрать в нем какой-то пункт, эмулируя нажатие "быстрой кдавиши" пункта меню. Если у Вашего пункта меню нет "быстрой клавиши" Вы можете посылать комбинации VK_MENU, VK_LEFT, VK_DOWN, и VK_RETURN, чтобы программно "путешествовать" по меню.
Пример:

procedure TForm1.Button1Click(Sender: TObject);
begin
        //Allow button to finish painting in response to the click
        Application.ProcessMessages;
        {Alt Key Down}
        keybd_Event(VK_MENU, 0, 0, 0);
        {F Key Down - Drops the menu down}
        keybd_Event(ord('F'), 0, 0, 0);
        {F Key Up}
        keybd_Event(ord('F'), 0, KEYEVENTF_KEYUP, 0);
        {Alt Key Up}
        keybd_Event(VK_MENU, 0, KEYEVENTF_KEYUP, 0);
        {F Key Down}
        keybd_Event(ord('S'), 0, 0, 0);
        {F Key Up}
        keybd_Event(ord('S'), 0, KEYEVENTF_KEYUP, 0);
end;

Наверх к содержанию

Как сделать клавишу-акселератор (keyboard shortcut)
компонету у которого нет заголовка?

Добавлено 15.10.2001
Возможный вариант - присвоить ссылку на этот компонент свойству FocusControl TLabel'а. В примере используется невидимый Label для создания "быстрой" клавиши (Alt+M) компонента Memo. Чтобы использовать пример, разместите на форме компонет TMemo, Label и несколько других компонентов, которые могут принимать фокус ввода. Запустите программу, перевидите фокус ввода куда-нибудь вне Memo и нажмите Alt+M - фокус ввода вернется в Memo.
Пример:

procedure TForm1.FormCreate(Sender: TObject);
begin
        Label1.Visible := false;
        Label1.Caption := '&M';
        Label1.FocusControl := Memo1;
end;

Наверх к содержанию

Можно ли как-то уменьшить мерцание при перерисовке
компонента?

Добавлено 18.10.2001
Если добавить флаг csOpaque (непрозрачный) к свойству ControlStyle компонента
- то фон компонента перерисовываться не будет.

Пример:

constructor TMyControl.Create;
begin
inherited;
ControlStyle := ControlStyle + [csOpaque];
end;

Наверх к содержанию

Как запретить изменение размера моего компонента
в design-time?
Добавлено 18.10.2001

Поместите в конструктор компонента код, устанавливающий размеры по умолчанию.
Переопределите метод SetBounds и проверяйте в нем "componentstate". Если компонет
находится режиме "design-time" (csDesigning in ComponentState) просто передавайте
значения ширины и высоты (width и heights) компонента по умолчанию (в нашем
примере 50) методу класса-предка.

Пример:

procedure TVu.SetBounds(ALeft : integer; ATop : integer; AWidth : integer;
        AHeight : integer);
begin
        if csdesigning in componentstate then
        begin
        AWidth := 50;
        AHeight := 50;
        inherited; //вызываем унаследованный от предка метод
        end;
end;

Наверх к содержанию

Можно ли уменьшить потребляемые компонентами
TNotebook и TTabbedNotebook ресурсы?
Добавлено 20.10.2001

Да. Можно уничтожать обьекты, расположенные не на текущей странице TNotebook или
TTabbedNotebook. В примере вызывается защищенный (Protected) метод путем создания
так называемый "class cracer'ов".

type TMyTabbedNotebook = class(TTabbedNotebook); //это наш "class cracer"
type TMyNotebook = class(TNotebook);

procedure TForm1.TabbedNotebook1Change(Sender: TObject; NewTab: Integer;
        var AllowChange: Boolean);
begin
        with TabbedNotebook1 do //вызываем защищенный метод родительского класса
        TMyTabbedNotebook(TWinControl(Pages.Objects[PageIndex])).DestroyHandle;
end;

procedure TForm1.TabSet1Change(Sender: TObject; NewTab: Integer;
        var AllowChange: Boolean);
begin
        with Notebook1 do //вызываем защищенный метод родительского класса
        TMyNotebook(TWinControl(Pages.Objects[PageIndex])).DestroyHandle;
        NoteBook1.PageIndex := NewTab;
        AllowChange := true
end;

Наверх к содержанию

     
TSelectableTree - TTreeView с возможностью MultiSelect'а

Добавлено 20.10.2001

TSelectableTree - наследник от TCustomTreeView, обладает
возможностью множественного выбора ( свойство MultiSelect ).

Соответственно дополнительные методы -

procedure SelectAll;
procedure UnSelectAll;
procedure InvertSelection;

Свойство DefaultPopup = True назначает для дерева PopUp-меню (по
правой кнопке мыши) со следующими пунктами:

Отметить все
Снять все пометки
Инверсия выделения

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

procedure TraverseTree(TreeView: TCustomTreeView; Node: TTreeNode;

  ATraverseTreeEvent : TTVTraverseEvent; AInfo : Pointer);

var

  CNode: TTreeNode;

begin

  if Assigned(ATraverseTreeEvent) then begin

    if Node = nil

      then CNode := TTreeView(TreeView).Items.GetFirstNode

      else CNode := Node;

    repeat

      ATraverseTreeEvent(CNode, AInfo);

      CNode := CNode.GetNext;

    until (CNode = nil) or (not CNode.HasAsParent(Node));

  end;

end;

TSelectableTree - наследник от TCustomTreeView, обладает возможностью множественного выбора ( свойство MultiSelect ).
Соответственно дополнительные методы -

procedure SelectAll;
procedure UnSelectAll;
procedure InvertSelection;

Свойство DefaultPopup = True назначает для дерева PopUp-меню (по
правой кнопке мыши) со следующими пунктами:

Отметить все
Снять все пометки
Инверсия выделения

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

procedure TraverseTree(TreeView: TCustomTreeView; Node: TTreeNode;

  ATraverseTreeEvent : TTVTraverseEvent; AInfo : Pointer);

var

  CNode: TTreeNode;

begin

  if Assigned(ATraverseTreeEvent) then begin

    if Node = nil

      then CNode := TTreeView(TreeView).Items.GetFirstNode

      else CNode := Node;

    repeat

      ATraverseTreeEvent(CNode, AInfo);

      CNode := CNode.GetNext;

    until (CNode = nil) or (not CNode.HasAsParent(Node));

  end;

end;

Наверх к содержанию.

Как получить горизонтальную прокрутку
(scrollbar) в ListBox?
Akzhan
Abdulin 24.10.2001

Так же как в случае с TMemo, здесь можно использовать сообщения. Например, сообщение может быть отослано в момент создания формы:

procedure TForm1.FormCreate(Sender: TObject);
begin
  ListBox1.Perform(LB_SETHORIZONTALEXTENT, 1000, Longint(0));
end;

Второй параметр в вызове - ширина прокрутки в точках.

Наверх к содержанию

Поиск строки в ListBox
Добавлено 27.10.2001
Есть функция API Windows, что заставляет искать строку в ListBox
с указанной позиции.

Например, поиск строки, что начинается на '1.' От текущей позиции курсора
в ListBox. Т.о., нажимая на кнопку Button1, будут перебраны все строки
начинающиеся на '1.'

procedure TForm1.Button1Click(Sender: TObject);
var S  : string;
begin
 S:='1.';
 with ListBox1 do
    ItemIndex := Perform(LB_SELECTSTRING, ItemIndex, LongInt(S));
end;

Более подробную информацию о работе команды LB_SELECTSTRING можно узнать
из Help-а Win32.

Наверх к содержанию

Имеется StringGrid с n-ым количеством строк.
Как вставить еще несколько строк в середину StringGrid или после определенной
строки?
Добавлено 3.11.2001

По-видимому, надо добавить строк в конец, изменив
Grid.RowCount, а потом раздвинуть строки циклом снизу вверх:

Grid.Rows.Strings[i] := Grid.Rows.Strings[i - 1];

Или я бы сделал метод рисования этой таблицы, а данные хранил бы в отдельном stringList-е, там есть методы вставки, а вообще-то для этих целей предпочитаю DrawGrid: переопределяю метод onDrawCell, всё же объектная модель лучше и данные проще контролировать.

Наверх к содержанию

Как вставить иконку (или bitmap) в TRichEdit, причем так, чтобы пользователь мог ее удалить нажатием клавиши Del (как это сделано в Microsoft Word)?

Добавлено 3.11.2001

Посмотрите компонент RichEdit98 (полностью бесплатный). ftp://ftp.bcsmi.minsk.by/alex/

Наверх к содержанию

Прокрутка
Memo (постранично), фокус находится на Edit1.

Совет взят с диска "All4Delphi" 5.11.2001

procedure TForm1.Edit1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);

begin

if Key = VK_F8 then

SendMessage(Memo1.Handle, { HWND для Memo }

WM_VSCROLL, { сообщение Windows }

SB_PAGEDOWN, {на страницу вниз }

0) { не используется }

else

if Key = VK_F7 then

SendMessage(Memo1.Handle, WM_VSCROLL, SB_PAGEUP, 0);

end;

Наверх к содержанию

Как
выполнить UnDo в Memo.
Если определено всплывающее(pop-up) меню для TMemo,и заданы клавиши для
операций Cut,Copy, Paste, то вы можете обрабатывать эти события вызывая
CuttoClipBoard, CopytoClipBoard, и т.д. Однако, если Вы поместили пункт
Undo в меню (обычно Ctrl+Z), то как дать знать TMemo, что нужно выполнить
Undo? Встроенного Undo для этого достаточно:

Memo1.Perform(EM_UNDO, 0, 0);
Для переключения enable/disable опции undo:

Undo1.Enabled := Memo1.Perform(EM_CANUNDO, 0, 0)<> 0;

Наверх к содержанию

Как можно определить, на какой строке в TMemo находится курсор?

Весь фокус в сообщении em_LineFromChar. Попробуйте:
procedure TmyForm.BitBtn1Click(Sender:
TObject);

var

iLine : Integer ;

begin

iLine := Memo1.Perform(em_LineFromChar, $FFFF, 0);

{ Внимание: номера строк начинаются с нуля }

MessageDlg('Line Number: ' + IntToStr(iLine), mtInformation, [mbOK], 0 ) ;

end;

Наверх к содержанию

Как
открыть ComboBox программно.
Добавлено 12.11.2001

У ComboBox есть run-time свойство, не упомянутое в On-Line Help - DroppedDown.
Для открытия ComboBox напишите:

ComboBox1.DroppedDown := True;

Естественно, False закроет его.

Наверх к содержанию

Переход
на другую страницу TabSet по имени.
Добавлено 12.11.2001

Поместите Tabset(TabSet1) и Edit (Edit1) на форму. Добавьте 4 страницы
в TabSet - свойство Tabs: Hello, World, Of, Delphi. Напишите обработчик
OnChange для Edit:

procedure Tform1.Edit1Change(Sender: TObject);

var

I : Integer;

begin

for I:= 0 to TabSet1.Tabs.Count - 1 do

if Edit1.Text = TabSet1.Tabs[I] then

TabSet1.TabIndex := I;

end;

Если набрать любое имя в Edit1, фокус установится на соответствующую страницу.

Наверх к содержанию

Как
вставить графику в ListBox или ComboBox
Возможность поместить графическое изображение в ListBox и ComboBox может
улучшить внешний вид вашего приложения и сделать пользовательский интерфейс
отличным от других. Ниже приведен пример, как это сделать шаг за шагом
...

Создать форму.
Поместить компоненты TComboBox и TListbox на форму.
Изменить свойство Style у TComboBox на csOwnerDrawVariable и lbOwnerDrawVariable для TListBox. Owner-Draw TListBox или TComboBox позволяют показать и объекты (например, картинку) и строки одновременно. В данном примере мы добавляем и графический объект и строку.
Создать 5 переменных типа TBitmap в разделе var модуля для формы.
Создать обработчики для событий OnCreate, OnDraw, OnMeasureItem, OnClose.

{START 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('Bitmap1 : Globe', TheBitmap1);

ComboBox1.Items.AddObject('Bitmap2 : Video', TheBitmap2);

ComboBox1.Items.AddObject('Bitmap3 : Gears', TheBitmap3);

ComboBox1.Items.AddObject('Bitmap4 : Key', TheBitmap4);

ComboBox1.Items.AddObject('Bitmap5 : Tools', TheBitmap5);

ListBox1.Items.AddObject('Bitmap1 : Globe', TheBitmap1);

ListBox1.Items.AddObject('Bitmap2 : Video', TheBitmap2);

ListBox1.Items.AddObject('Bitmap3 : Gears', TheBitmap3);

ListBox1.Items.AddObject('Bitmap4 : Key', TheBitmap4);

ListBox1.Items.AddObject('Bitmap5 : Tools', 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;

{ display the text }

TextOut(Rect.Left + Offset, Rect.Top, Combobox1.Items[Index]);

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;

{ display the text }

TextOut(Rect.Left + Offset, Rect.Top, Listbox1.Items[Index]);

end;

procedure TForm1.ListBox1MeasureItem(Control : TwinControl; Index : Integer; var Height : Integer);

begin

Height := 20;

end;

end.

{END OWNERDRW.PAS}

{START 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

Наверх к содержанию

Используются технологии uCoz