Программирование -> Delphi / Pascal -> FAQ по Delphi

Вопрос:

Как разместить прозрачную надпись на 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'а по заголовку?

Ответ:

Пример:

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;


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




Вопрос:

Ответ:
Можно перехватить сообщение 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?

Ответ:

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


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




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

Ответ:

Пример:

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;


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




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

Ответ:

Пример:

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;


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




Вопрос:

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

Пример:

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


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




Вопрос:

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

Ответ:

Пример:
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?

Ответ:

Пример:

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;


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




Вопрос:

Ответ:

Пример:

SysUtils.Abort;


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




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

Ответ:

Пример:

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;


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




Вопрос:

Ответ:
В примере стили шрифта меняются по нажатию след. комбинаций клавиш
        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;


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




Вопрос:

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

Пример:

uses Registry;

procedure TForm1.Button1Click(Sender: TObject);
var
        WinIni : TRegIniFile;
begin
        WinIni := TRegIniFile.Create('');
        WinIni.RootKey := HKEY_LOCAL_MACHINE;
        WinIni.WriteString('Frank','Borland','Writes Fast Code!');
        WinIni.Free;
end;


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




Вопрос:

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

Ответ:

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




Вопрос:

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

Ответ:

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

Пример:

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


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




Вопрос:

Ответ:

Примечание: Вам придется редактировать этот код, если Вы добавите в приложение новые формы.

begin
        Application.Initialize;
        if <какое-то условие> then 
                begin
                        Application.CreateForm(TForm1, Form1);
                        Application.CreateForm(TForm2, Form2);
                end 
        else 
                begin
                        Application.CreateForm(TForm2, Form2);
                        Application.CreateForm(TForm1, Form1);
                end;
end.
Application.Run;


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




Вопрос:

Ответ:
В примере используется метод 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) рисуют на один пиксел короче?

Ответ:

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




Вопрос:
Как показать подсказки "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;


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




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

Ответ:

procedure TForm1.Button1Click(Sender: TObject);
var
        DirInfo: TSearchRec;
        r: integer;
begin
        r := FindFirst('C:\Download\*.*', FaAnyfile, DirInfo);
        while r = 0 do
        begin
                if ((DirInfo.Attr and FaDirectory <> FaDirectory) and
                        (DirInfo.Attr and FaVolumeId <> FaVolumeID)) then
                if DeleteFile(pChar('C:\Download\' + DirInfo.Name))= false then
                        ShowMessage('Unable to delete: C:\Download\'+DirInfo.Name);
                r := FindNext(DirInfo);
        end;
        SysUtils.FindClose(DirInfo);
        if RemoveDirectory('C:\Download\') = false then
                ShowMessage('Unable to delete directory: C:\Download\');
end;


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




Вопрос:

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

Пример:

procedure TForm1.Button1Click(Sender: TObject);
begin
        {Disable}
        Form1.BorderIcons := Form1.BorderIcons - [biSystemMenu, biMinimize, biMaximize];
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
        {Enable}
        Form1.BorderIcons := Form1.BorderIcons + [biSystemMenu, biMinimize, biMaximize];
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?

Ответ:

Пример:

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


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




Вопрос:
Как проигрываеть MPEG файл в Delphi-программе?

Ответ:

Если в системе Windows MMSystem установлен декодер MPEG - используя компонент 
TMediaPlayer

Пример:

procedure TForm1.Button1Click(Sender: TObject);
begin
        MediaPlayer1.Filename := 'C:\DownLoad\rsgrow.mpg';
        MediaPlayer1.Open;
        MediaPlayer1.Display := Panel1;
        MediaPlayer1.DisplayRect := Panel1.ClientRect;
        MediaPlayer1.Play;
end;


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




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

Ответ:

Пример:

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.


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




Вопрос:
Как определить наличие сопроцессора?

Ответ:

Пример:

{$IFDEF WIN32}

uses Registry;

{$ENDIF}

function HasCoProcesser : bool;
{$IFDEF WIN32}
var
        TheKey : hKey;
{$ENDIF}
begin
        Result := true;
        {$IFNDEF WIN32}
        if GetWinFlags and Wf_80x87 = 0 then
        Result := false;
        {$ELSE}
        if RegOpenKeyEx(HKEY_LOCAL_MACHINE,
        'HARDWARE\DESCRIPTION\System\FloatingPointProcessor',0,
        KEY_EXECUTE, TheKey) <> ERROR_SUCCESS then result := false;
        RegCloseKey(TheKey);
{$ENDIF}
        end;

procedure TForm1.Button1Click(Sender: TObject);
begin
        if HasCoProcesser then
                ShowMessage('Has CoProcessor') 
        else
                ShowMessage('No CoProcessor - Windows Emulation Mode');
end;


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




Вопрос:
Как узнать серийный номер аудио CD?

Ответ:

Пример:

uses MMSystem, MPlayer;

procedure TForm1.Button1Click(Sender: TObject);
var
        mp : TMediaPlayer;
        msp : TMCI_INFO_PARMS;
        MediaString : array[0..255] of char;
        ret : longint;
begin
        mp := TMediaPlayer.Create(nil);
        mp.Visible := false;
        mp.Parent := Application.MainForm;
        mp.Shareable := true;
        mp.DeviceType := dtCDAudio;
        mp.FileName := 'D:';
        mp.Open;
        Application.ProcessMessages;
        FillChar(MediaString, sizeof(MediaString), #0);
        FillChar(msp, sizeof(msp), #0);
        msp.lpstrReturn := @MediaString;
        msp.dwRetSize := 255;
        ret := mciSendCommand(Mp.DeviceId, MCI_INFO, MCI_INFO_MEDIA_IDENTITY,
                        longint(@msp));
        if Ret <> 0 then
                begin
                        MciGetErrorString(ret, @MediaString, sizeof(MediaString));
                        Memo1.Lines.Add(StrPas(MediaString));
                end
        else
                Memo1.Lines.Add(StrPas(MediaString));
        mp.Close;
        Application.ProcessMessages;
        mp.free;
end;
end.


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




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

Ответ:

Пример:

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;


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




Вопрос:
Как узнать, что курсор мыши над моей формой?

Ответ:
Можно использовать функцию GetCapture() из Windows API.

Примечание: Cм. документацию Windows для информации об ограничениях функции GetCapture.

Пример:

procedure TForm1.FormDeactivate(Sender: TObject);
begin
        ReleaseCapture;
end;

procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
        If GetCapture = 0 then
                SetCapture(Form1.Handle);
        if PtInRect(Rect(Form1.Left,Form1.Top,Form1.Left + Form1.Width,
                        Form1.Top + Form1.Height), ClientToScreen(Point(x, y))) then
                Form1.Caption := 'Мышка над формой!'
        else
                Form1.Caption := 'Мышка вне формы...';
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?

Ответ:

Пример:

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?

Ответ:

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?

Ответ:

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;


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




Вопрос:

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

Пример:

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;


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




Вопрос:

Ответ:

Пример:

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" еще раз.


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




Вопрос:
Можно ли создать форму, которая получает дополнительные параметры в методе Сreate?

Ответ:
Просто замените конструктор Create класса Вашей формы.

Пример:

unit Unit2;

interface

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

type
        TForm2 = class(TForm)
        private
                {Private declarations}
        public
                constructor CreateWithCaption(aOwner: TComponent; aCaption: string);
                {Public declarations} 
end;

var
        Form2: TForm2;

implementation

{$R *.DFM}

constructor TForm2.CreateWithCaption(aOwner: TComponent; aCaption: string);
begin
        Create(aOwner);
        Caption := aCaption;
end;

uses Unit2;
procedure TForm1.Button1Click(Sender: TObject);
begin
        Unit2.Form2 :=Unit2.TForm2.CreateWithCaption(Application, 'My Caption');
        Unit2.Form2.Show;
end;


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




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

Ответ:

Пример:

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;


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




Вопрос:

Ответ:

Пример:

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;


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




Вопрос:

Ответ:

Пример:

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;


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




Вопрос:

Ответ:

Пример:

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 используя массив точек?

Ответ:

Пример:

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;


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




Вопрос:

Ответ:

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




Вопрос:

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

Пример:

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;


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




Вопрос:
Как узнать есть ли в заданном CD-ROM'е Audio CD?

Ответ:

Пример:

function IsAudioCD(Drive : char) : bool;
var
        DrivePath : string;
        MaximumComponentLength : DWORD;
        FileSystemFlags : DWORD;
        VolumeName : string;
Begin
        sult := false;
        DrivePath := Drive + ':\';
        if GetDriveType(PChar(DrivePath)) <> DRIVE_CDROM then 
                exit;
        SetLength(VolumeName, 64);
        GetVolumeInformation(PChar(DrivePath),PChar(VolumeName),
        Length(VolumeName),nil,MaximumComponentLength,FileSystemFlags,nil,0);
        if lStrCmp(PChar(VolumeName),'Audio CD') = 0 then
                result := true;
end;

function PlayAudioCD(Drive : char) : bool;
var
        mp : TMediaPlayer;
begin
        result := false;
        Application.ProcessMessages;
        if not IsAudioCD(Drive) then
                exit;
        mp := TMediaPlayer.Create(nil);
        mp.Visible := false;
        mp.Parent := Application.MainForm;
        mp.Shareable := true;
        mp.DeviceType := dtCDAudio;
        mp.FileName := Drive + ':';
        mp.Shareable := true;
        mp.Open;
        Application.ProcessMessages;
        mp.Play;
        Application.ProcessMessages;
        mp.Close;
        Application.ProcessMessages;
        mp.free;
        result := true;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
        if not PlayAudioCD('D') then
                ShowMessage('Not an Audio CD');
end;


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




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

Ответ:
Свойство "WheelPresent" глобального обьекта "mouse".


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




Вопрос:

Ответ:

Пример:

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)?

Ответ:

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




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

Ответ:
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;


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




Вопрос:
Как при проигрывании музыки с Audio CD показывать сколько прошло минут и секунд?

Ответ:
В примере время выводится по таймеру.

Пример:

uses MMSystem;

procedure TForm1.Timer1Timer(Sender: TObject);
var
        Trk : Word;
        Min : Word;
        Sec : Word;
begin
        with MediaPlayer1 do
                begin
                        Trk := MCI_TMSF_TRACK(Position);
                        Min := MCI_TMSF_MINUTE(Position);
                        Sec := MCI_TMSF_SECOND(Position);
                        Label1.Caption := Format('%.2d',[Trk]);
                        Label2.Caption := Format('%.2d:%.2d',[Min,Sec]);
                end;
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;

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




Вопрос:

Ответ:

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




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

Ответ:

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;


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




Вопрос:
Как узнать число кадров AVI файла, и выяснить как долго будет проигрывться этот файл?

Ответ:
В приведенном примере указано как получить эту информацию.

Пример:

procedure TForm1.Button1Click(Sender: TObject);
begin
        MediaPlayer1.TimeFormat := tfFrames;
        ShowMessage('Number of frames = ' + IntToStr(MediaPlayer1.Length));
        MediaPlayer1.TimeFormat := tfMilliseconds;
        ShowMessage('Number of milliseconds = ' + IntToStr(MediaPlayer1.Length));
end;


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




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

Пример:

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


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




Вопрос:

Ответ:

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 в какой-либо момент времени?

Ответ:

Пример:

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;


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




Вопрос:
Есть ли в Delphi эквивалент функции SendKeys Visual Basic'а?

Ответ:

Пример:

procedure SimulateKeyDown(Key : byte);
begin
        keybd_event(Key, 0, 0, 0);
end;

procedure SimulateKeyUp(Key : byte);
begin
        keybd_event(Key, 0, KEYEVENTF_KEYUP, 0);
end;

procedure SimulateKeystroke(Key : byte; extra : DWORD);
begin
        keybd_event(Key,extra,0,0);
        keybd_event(Key,extra,KEYEVENTF_KEYUP,0);
end;

procedure SendKeys(s : string);
var
        i : integer;
        flag : bool;
        w : word;
begin
        {Get the state of the caps lock key}
        flag := not GetKeyState(VK_CAPITAL) and 1 = 0;
        {If the caps lock key is on then turn it off}
        if flag then
                SimulateKeystroke(VK_CAPITAL, 0);
        for i := 1 to Length(s) do
                begin
                        w := VkKeyScan(s[i]);
                        {If there is not an error in the key translation}
                        if ((HiByte(w) <> $FF) and (LoByte(w) <> $FF)) then
                                begin
                                        {If the key requires the shift key down - hold it down}
                                        if HiByte(w) and 1 = 1 then
                                                SimulateKeyDown(VK_SHIFT);
                                                {Send the VK_KEY}
                                        SimulateKeystroke(LoByte(w), 0);
                                        {If the key required the shift key down - release it}
                                        if HiByte(w) and 1 = 1 then
                                                SimulateKeyUp(VK_SHIFT);
                                end;
                end;
{if the caps lock key was on at start, turn it back on}
if flag then
        SimulateKeystroke(VK_CAPITAL, 0);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
        {Toggle the cap lock}
        SimulateKeystroke(VK_CAPITAL, 0);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
        {Capture the entire screen to the clipboard}
        {by simulating pressing the PrintScreen key}
        SimulateKeystroke(VK_SNAPSHOT, 0);
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
        {Capture the active window to the clipboard}
        {by simulating pressing the PrintScreen key}
        SimulateKeystroke(VK_SNAPSHOT, 1);
end;

procedure TForm1.Button4Click(Sender: TObject);
begin
        {Set the focus to a window (edit control) and send it a string}
        Application.ProcessMessages;
        Edit1.SetFocus;
        SendKeys('Delphi Is RAD!');
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;


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




Вопрос:
Как заставить TMediaPlayer проигрывать одно и тоже бесконечно? AVI например?

Ответ:
В примере AVI файл проигрывается снова и снова - используем событие MediaPlayer'а Notify

Пример:

procedure TForm1.MediaPlayer1Notify(Sender: TObject);
begin
        with MediaPlayer1 do
                if NotifyValue = nvSuccessful then
                        begin
                                Notify := True;
                                Play;
                        end;
end;


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




Вопрос:

Ответ:

Пример:

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;


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




Вопрос:
Как сменить дисковод, откуда  MediaPlayer проигрывает аудио CD?

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

Пример:

MediaPlayer1.FileName := 'E:';


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




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

Ответ:

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

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?

Ответ:

Пример: 

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;


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




Вопрос:

Ответ:

Пример:

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


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




Вопрос:
Как показать первый кадр AVI-файла?

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

procedure TForm1.Button1Click(Sender: TObject);
begin
        Application.ProcessMessages;
        MediaPlayer1.Open;
        Application.ProcessMessages;
        MediaPlayer1.Step;
        Application.ProcessMessages;
        MediaPlayer1.Previous;
end;


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




Вопрос:
Когда пользователь щелкает по 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;


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




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

Ответ:

Пример:

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;


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




Вопрос:

Ответ:
Эту информацию можно получить из реестра.

Пример:
uses Registry;

procedure TForm1.Button1Click(Sender: TObject);
var
        reg: TRegistry;
begin
        reg := TRegistry.Create;
        reg.RootKey := HKEY_LOCAL_MACHINE;
        reg.OpenKey('Software\Microsoft\Windows\CurrentVersion\SETUP',false);
        ShowMessage(reg.ReadString('SourcePath'));
        reg.CloseKey;
        reg.free;
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;


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




Вопрос:

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

Пример:

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?

Ответ:

Пример:

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 с показанным выпадающим списком до показа списка?

Ответ:

Пример:

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 имели работали не только в режиме вставки символов,
но и в режиме замены?

Ответ:

Пример:

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;


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




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

Ответ:

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




Вопрос:
При попытке присвоить значение свойству "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'а?

Ответ:

Пример:

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;


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




Вопрос:
Как сохранить обьект TFont в реестре/ini/файле/таблице базы данных?

Ответ:

Uses    ... Registry;

procedure SaveFontToRegistry(Font : TFont; SubKey : String);
Var
        R : TRegistry;
        FontStyleInt : byte;
        FS : TFontStyles;
begin
        R:=TRegistry.Create;
        try
                FS:=Font.Style;
                Move(FS,FontStyleInt,1);
                R.OpenKey(SubKey,True);
                R.WriteString('Font Name',Font.Name);
                R.WriteInteger('Color',Font.Color);
                R.WriteInteger('CharSet',Font.Charset);
                R.WriteInteger('Size',Font.Size);
                R.WriteInteger('Style',FontStyleInt);
        finally
                R.Free;
        end;
end;

function ReadFontFromRegistry(Font : TFont; SubKey : String) : boolean;
Var
        R : TRegistry;
        FontStyleInt : byte;
        FS : TFontStyles;
begin
        R:=TRegistry.Create;
        try
                result:=R.OpenKey(SubKey,false); if not result then exit;
                Font.Name:=R.ReadString('Font Name');
                Font.Color:=R.ReadInteger('Color');
                Font.Charset:=R.ReadInteger('CharSet');
                Font.Size:=R.ReadInteger('Size');
                FontStyleInt:=R.ReadInteger('Style');
                Move(FontStyleInt,FS,1);
                Font.Style:=FS;
        finally
                R.Free;
        end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
        If FontDialog1.Execute then
        begin
                SaveFontToRegistry(FontDialog1.Font,'Delphi Kingdom\Fonts');
        end;
end;

procedure TForm1.Button2Click(Sender: TObject);
var
        NFont : TFont;
begin
        NFont:=TFont.Create;
        if ReadFontFromRegistry(NFont,'Delphi Kingdom\Fonts') then
        begin //здесь добавить проверку - существует ли шрифт
                Label1.Font.Assign(NFont);
                NFont.Free;
        end;
end;


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




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

Ответ:

Пример:

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 работает не достаточно точно. Как получить более высокую точность?

Ответ:

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




Вопрос:
Как поместить 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;


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




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

Ответ:

Пример:

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 в реим редактирования и установить курсор в
окошке редактирования в требуемую позицию?

Ответ:

Пример:

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 дисков?

Ответ:
Следующий пример вызывает защищенный (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;


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




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

Ответ:

Пример:

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) компонету у которого нет заголовка?

Ответ:

Пример:

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


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




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

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

Пример:

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


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




Вопрос:
Как запретить изменение размера моего компонента в design-time?

Ответ:
Поместите в конструктор компонента код, устанавливающий размеры по умолчанию.
Переопределите метод 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 ресурсы?

Ответ:
Да. Можно уничтожать обьекты, расположенные не на текущей странице 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;


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




Вопрос:
Функция keybd_event() принимает значения до 244 - как мне отправить нажатие
клавиши с кодом #255 в элемент управления Windows?

Ответ:
Это может понадобится для иностранных языков или для специальных символов. (например,
в русских шрифтах символ с кодом #255 - я прописное). Приведенный в примере метод,
не стоит использовать в случае если символ может быть передан обычным способом
(функцией keybd_event()).
 
procedure TForm1.Button1Click(Sender: TObject);
var
        KeyData : packed record
                RepeatCount : word;
                ScanCode : byte;
                Bits : byte;
        end;
begin
        {Let the button repaint}
        Application.ProcessMessages;
        {Set the focus to the window}
        Edit1.SetFocus;
        {Send a right so the char is added to the end of the line}
        //  SimulateKeyStroke(VK_RIGHT, 0);
        keybd_event(VK_RIGHT, 0,0,0);
        {Let the app get the message}
        Application.ProcessMessages;
        FillChar(KeyData, sizeof(KeyData), #0);
        KeyData.ScanCode := 255;
        KeyData.RepeatCount := 1;
        SendMessage(Edit1.Handle, WM_KEYDOWN, 255,LongInt(KeyData));
        KeyData.Bits := KeyData.Bits or (1 shl 30);
        KeyData.Bits := KeyData.Bits or (1 shl 31);
        SendMessage(Edit1.Handle, WM_KEYUP, 255, LongInt(KeyData));
        KeyData.Bits := KeyData.Bits and not (1 shl 30);
        KeyData.Bits := KeyData.Bits and not (1 shl 31);
        SendMessage(Edit1.Handle, WM_CHAR, 255, LongInt(KeyData));
        Application.ProcessMessages;
end;


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




Вопрос:
Некоторые компоненты не меняют курсор мыши до тех пор пока пользователь не
сдвинет мышь. Как эмулировать движение мыши?

Ответ:
В примере мышка слегка "подталкивается" без участия пользователя.

procedure TForm1.Button1Click(Sender: TObject);
var
        pt : TPoint;
begin
        Application.ProcessMessages;
        Screen.Cursor := CrHourglass;
        GetCursorPos(pt);
        SetCursorPos(pt.x + 1, pt.y + 1);
        Application.ProcessMessages;
        SetCursorPos(pt.x - 1, pt.y - 1);
end;


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




Вопрос:
Как зарегистрировать расширение файла за своим приложением и контекстное меню,
связанное с этим типом?

Ответ:
Пример регистрирует расширение файла(.myext) - файлы этого типа будут открываться
приложением MyApp.Exe. Также регнстрируется одно действие (action) по умолчанию
для файлов этого типа и два дополнительных пункта контекстного меню, связанного с
этим типом файлов. Возможно, потребуется перезайти в систему чтобы изменения
вступили в силу.

Пример:

uses
        Registry;

procedure TForm1.Button1Click(Sender: TObject);
var
        R : TRegIniFile;
begin
        R := TRegIniFile.Create('');
        with R do
                begin
                        RootKey := HKEY_CLASSES_ROOT;
                        WriteString('.myext','','MyExt');
                        WriteString('MyExt','','Some description of MyExt files');
                        WriteString('MyExt\DefaultIcon','','C:\MyApp.Exe,0');
                        WriteString('MyExt\Shell','','This_Is_Our_Default_Action');
                        WriteString('MyExt\Shell\First_Action',
                                                '','This is our first action');
                        WriteString('MyExt\Shell\First_Action\command','',
                                                'C:\MyApp.Exe /LotsOfParamaters %1');
                        WriteString('MyExt\Shell\This_Is_Our_Default_Action','',
                                                'This is our default action');
                        WriteString('MyExt\Shell\This_Is_Our_Default_Action\command',
                                                '','C:\MyApp.Exe %1');
                        WriteString('MyExt\Shell\Second_Action',
                                                '','This is our second action');
                        WriteString('MyExt\Shell\Second_Action\command',
                                                '','C:\MyApp.Exe /TonsOfParameters %1');
                        Free;
                end;
end;




	
1-я страница
	
2-я страница
	
3-я страница
	
4-я страница