|
Прочее
Этот раздел включает в себя то, что не вошло в разделы Система и Железо
Внимание !! Сайт переехал - он теперь расположен
по адресу http://z-oleg.com/delphi, размещенные
там материалы переработаны и дополнены. На z-ol.chat.ru остается копия, однако
обновляться она больше не будет
|
|
|
|
Тонкости работы с ListBox
Тонкости работы с Memo и RichEdit
Как получить горизонтальную прокрутку (scrollbar) в ListBox? |
* |
* |
|
Так же как в случае с TMemo, здесь можно использовать сообщения. Например,
сообщение может быть отослано в момент создания формы:
procedure TForm1.FormCreate(Sender: TObject);
begin
ListBox1.Perform(LB_SETHORIZONTALEXTENT, 1000, Longint(0));
end;
Второй параметр в вызове - ширина прокрутки в точках.
Поиск строки в ListBox |
* |
* |
|
Есть функция API Windows, позволяющая искать строку в ListBox с указанной
позиции.
Например, поиск строки, что начинается с '1.' От текущей позиции курсора в
ListBox. Т.о., нажимая на кнопку Button1, будут перебраны все строки,
начинающиеся на '1.'
procedure TForm1.Button1Click(Sender: TObject);
var S : string;
begin
S:='1.';
with ListBox1 do
ItemIndex := Perform(LB_SELECTSTRING, ItemIndex, LongInt(S));
end;
Более подробную информацию о работе команды LB_SELECTSTRING можно узнать из
справки Win32
Пример получения позиции курсора компоненты TMemo. |
* |
* |
|
procedure TForm1.Memo1KeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
Memo1Click(Self);
end;
procedure TForm1.Memo1Click(Sender: TObject);
VAR
LineNum : LongInt;
CharNum : LongInt;
begin
// Получение номера строки
LineNum := Memo1.Perform(EM_LINEFROMCHAR, Memo1.SelStart, 0);
// Получение номера символа в строке
CharNum := Memo1.Perform(EM_LINEINDEX, LineNum, 0);
// Их отображение
Label1.Caption := IntToStr(LineNum+1)+' : '+IntToStr((Memo1.SelStart-CharNum)+1);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
Memo1Click(Self);
end;
Функция Undo в TMemo |
*,W=* |
|
|
В компоненте TMemo предусмотрена функция отмены
последней правки (Undo). Ее можно вызвать следующим
образом:
Memo1.Perform(EM_UNDO,0,0);
Узнать о том, возможна ли отмена (т.е. есть ли что
отменять) можно следующим образом:
UndoEnabled:=(Memo1.Perform(EM_CAUNDO,0,0)<>0);
Как прокрутить текст в Tmemo или в TRichEdit |
* |
* |
|
Для прокрутки текста следует применить следующий вызов (в данном случае
прокрутка идет в конец текста)
SendMessage(Memo1.Handle, EM_LINESCROLL, 0, Memo1.Lines.Count-1);
Пример вывода сообщения одной командой и ввода строки одной командой. |
* |
* |
|
Вывод сообщения:
ShowMessage('сообщение');
Ввод текста от пользователя:
S:=InputBox('Заголовок', 'Сообщение', S{строка по умолчанию});
unit Unit1;
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
Button2: TButton;
Button3: TButton;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure Button3Click(Sender: TObject);
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage('Пример простого сообщения.'+#10+
'Данное сообщение выводится всегда в центре экрана.');
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
ShowMessagePos('Пример сообщения с указанием его положения на экране.',
Form1.Left+Button2.Left, Form1.Top+Button2.Top);
end;
procedure TForm1.Button3Click(Sender: TObject);
begin
Button3.Caption := InputBox('Delphi для всех', 'Введите строку:', Button3.Caption);
end;
end.
Перетаскивание формы за ее поле |
* |
* |
|
procedure TForm1.MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
const
SC_DragMove = $F012; { a magic number }
begin
ReleaseCapture;
perform(WM_SysCommand, SC_DragMove, 0);
end;
Легко заметить, что перетаскивание формы возможно не только за поле, а за любой
компонент, например, панель
Как сделать так, что при нажатии на Enter происходил переход к следующему элементу формы |
* |
* |
|
Ставите у формы KeyPreview = true и создаете событие KeyPress
следующего вида:
procedure TForm1.FormKeyPress(Sender: TObject; var Key: Char);
begin
if (Key = #13) then begin
Key:=#0;
Perform(WM_NEXTDLGCTL,0,0);
end;
end;
Следует заметить, что в реальном приложении стоит проверить, какой компонент в фокусе ввода.
Для компонент, допускающих многострочный ввод, данный пример недопустим - он не позволит им
нормально работать. Пример:
procedure TForm1.FormKeyPress(Sender: TObject; var Key: Char);
begin
if (Key = #13) then
if not (ActiveControl is TMemo) then // проверка типа компонента
begin
Key:=#0;
Perform(WM_NEXTDLGCTL,0,0);
end;
end;
Перетаскивание файла |
* |
* |
|
// На эту форму можно бросить файл (например из проводника) и он будет открыт
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics,
Controls, Forms, Dialogs,StdCtrls,
ShellAPI // обязательно!;
type
TForm1 = class(TForm)
Memo1: TMemo;
FileNameLabel: TLabel;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
protected
// Это процедура, отвечающая за прием сообщения о броске файла
procedure WMDropFiles(var Msg: TMessage); message wm_DropFiles;
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.WMDropFiles(var Msg: TMessage);
var
Filename: array[0 .. 256] of Char;
Count : integer;
begin
// Получаем количество файлов (просто пример)
nCount := DragQueryFile( msg.WParam, $FFFFFFFF, acFileName, cnMaxFileNameLen);
// Получаем имя первого файла }
DragQueryFile( THandle(Msg.WParam),
0, { это номер файла }
Filename,SizeOf(Filename) ) ;
// Открываем его
with FileNameLabel do begin
Caption := LowerCase(StrPas(FileName));
Memo1.Lines.LoadfromFile(Caption);
end;
// Отдаем сообщение о завершении процесса
DragFinish(THandle(Msg.WParam));
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
// Уведомляем Windows, что на объект с указанным Handle можно бросать файлы
DragAcceptFiles(Handle, True);
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
DragAcceptFiles(Handle, False);
end;
end.
Привлечение внимания к окну |
* |
* |
|
Часто возникает проблема - в многооконном
приложении необходимо обратить внимание
пользователя на то, что какое-то из окон требует
внимания (например, к нему пришло сообщение по DDE,
в нем завершился какой-либо процесс, произошла
ошибка ...). Это легко сделать, используя команду API
FlashWindow:
procedure TForm1.Timer1Timer(Sender: TObject);
begin
FlashWindow(Handle,true);
end;
В данном примере FlashWindow вызывается по
таймеру ежесекундно, что приводит к миганию
заголовка окна.
Заставка для программы |
* |
* |
|
Сведения о программе, авторские права и т.д.,
лучше оформить в виде отдельной формы и
показывать ее при запуске программы (как это
сделано в Word).
Сделать это не сложно:
1. Создаете форму (например SplashForm).
2. Объявляете ее свободной (availableForms).
3. В Progect Source вставляете следующее (например):
Program Splashin;
uses
Forms,
Main in 'MAIN.PAS',
Splash in 'SPLASH.PAS'
{$R *.RES}
begin
try
SlashForm := TSplashForm.Create(Application);
SplashForm.Show;
SplashForm.Update;
Application.CreateForm(TMainForm, MainForm);
SplashForm.Hide;
finally
SplashForm.Free;
end;
Application.Run;
end.
И форма SplashForm держится на экране пока
выполняется Create в главной форме. Но иногда она
появляется и пропадает очень быстро, поэтому
нужно сделать задержку:
1. Добавляете на форму таймер с событием:
procedure TSplashForm.Timer1Timer(Sender: TObject);
begin
Timer1.Enabled := False;
end;
2. Событие onCloseQuery для формы:
procedure TSplashForm.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
CanClose := Not Timer1.Enabled;
end;
3. И перед SplashForm.Hide; ставите цикл:
repeat
Application.ProcessMessages;
until SplashForm.CloseQuery;
4. Все! Осталось установить на таймере
период задержки 3-4 секунды.
5. На последок, у такой формы желательно убрать
Caption:
SetWindowLong (Main.Handle,GWL_STYLE, GetWindowLong(Main.Handle, GWL_STYLE) AND NOT
WS_CAPTION OR WS_SIZEBOX);
Создание прозрачной формы |
* |
* |
|
unit unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
type
TForm1 = class(TForm)
// это просто кнопки на форме - для демонстрации
Button1: TButton;
Button2: TButton;
protected
procedure RebuildWindowRgn;
procedure Resize; override;
public
constructor Create(AOwner: TComponent); override;
end;
var
Form1 : TForm1;
implementation
{$R *.DFM}
// Прозрачная форма
constructor TForm1.Create(AOwner: TComponent);
begin
inherited;
// На всякий случай убираем сколлбары, чтобы не мешались
HorzScrollBar.Visible:= False;
VertScrollBar.Visible:= False;
// строим новый регион
RebuildWindowRgn;
end;
procedure TForm1.Resize;
begin
inherited;
// строим новый регион
RebuildWindowRgn;
end;
procedure TForm1.RebuildWindowRgn;
var
FullRgn, Rgn: THandle;
ClientX, ClientY, I: Integer;
begin
// определяем относительные координаты клиенской части
ClientX:= (Width - ClientWidth) div 2;
ClientY:= Height - ClientHeight - ClientX;
// создаем регион для всей формы
FullRgn:= CreateRectRgn(0, 0, Width, Height);
// создаем регион для клиентской части формы
// и вычитаем его из FullRgn
Rgn:= CreateRectRgn(ClientX, ClientY, ClientX + ClientWidth, ClientY +
ClientHeight);
CombineRgn(FullRgn, FullRgn, Rgn, rgn_Diff);
// теперь добавляем к FullRgn регионы каждого контрольного элемента
for I:= 0 to ControlCount -1 do
with Controls[I] do begin
Rgn:= CreateRectRgn(ClientX + Left, ClientY + Top, ClientX + Left +
Width, ClientY + Top + Height);
CombineRgn(FullRgn, FullRgn, Rgn, rgn_Or);
end;
// устанавливаем новый регион окна
SetWindowRgn(Handle, FullRgn, True);
end;
end.
Создание окна непрямоугольной формы |
* |
* |
|
unit rgnu;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Buttons, Menus;
type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure FormPaint(Sender: TObject);
private
{ Private declarations }
rTitleBar : THandle;
Center : TPoint;
CapY : Integer;
Circum : Double;
SB1 : TSpeedButton;
RL, RR : Double;
procedure TitleBar(Act : Boolean);
procedure WMNCHITTEST(var Msg: TWMNCHitTest);
message WM_NCHITTEST;
procedure WMNCACTIVATE(var Msg: TWMNCACTIVATE);
message WM_NCACTIVATE;
procedure WMSetText(var Msg: TWMSetText);
message WM_SETTEXT;
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
CONST
TitlColors : ARRAY[Boolean] OF TColor =
(clInactiveCaption, clActiveCaption);
TxtColors : ARRAY[Boolean] OF TColor =
(clInactiveCaptionText, clCaptionText);
procedure TForm1.FormCreate(Sender: TObject);
VAR
rTemp, rTemp2 : THandle;
Vertices : ARRAY[0..2] OF TPoint;
X, Y : INteger;
begin
Caption := 'OOOH! Doughnuts!';
BorderStyle := bsNone; {required}
IF Width > Height THEN Width := Height
ELSE Height := Width; {harder to calc if width <> height}
Center := Point(Width DIV 2, Height DIV 2);
CapY := GetSystemMetrics(SM_CYCAPTION)+8;
rTemp := CreateEllipticRgn(0, 0, Width, Height);
rTemp2 := CreateEllipticRgn((Width DIV 4), (Height DIV 4),
3*(Width DIV 4), 3*(Height DIV 4));
CombineRgn(rTemp, rTemp, rTemp2, RGN_DIFF);
SetWindowRgn(Handle, rTemp, True);
DeleteObject(rTemp2);
rTitleBar := CreateEllipticRgn(4, 4, Width-4, Height-4);
rTemp := CreateEllipticRgn(CapY, CapY, Width-CapY, Height-CapY);
CombineRgn(rTitleBar, rTitleBar, rTemp, RGN_DIFF);
Vertices[0] := Point(0,0);
Vertices[1] := Point(Width, 0);
Vertices[2] := Point(Width DIV 2, Height DIV 2);
rTemp := CreatePolygonRgn(Vertices, 3, ALTERNATE);
CombineRgn(rTitleBar, rTitleBar, rTemp, RGN_AND);
DeleteObject(rTemp);
RL := ArcTan(Width / Height);
RR := -RL + (22 / Center.X);
X := Center.X-Round((Center.X-1-(CapY DIV 2))*Sin(RR));
Y := Center.Y-Round((Center.Y-1-(CapY DIV 2))*Cos(RR));
SB1 := TSpeedButton.Create(Self);
WITH SB1 DO
BEGIN
Parent := Self;
Left := X;
Top := Y;
Width := 14;
Height := 14;
OnClick := Button1Click;
Caption := 'X';
Font.Style := [fsBold];
END;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Close;
End;
procedure TForm1.WMNCHITTEST(var Msg: TWMNCHitTest);
begin
Inherited;
WITH Msg DO
WITH ScreenToClient(Point(XPos,YPos)) DO
IF PtInRegion(rTitleBar, X, Y) AND
(NOT PtInRect(SB1.BoundsRect, Point(X,Y))) THEN
Result := htCaption;
end;
procedure TForm1.WMNCActivate(var Msg: TWMncActivate);
begin
Inherited;
TitleBar(Msg.Active);
end;
procedure TForm1.WMSetText(var Msg: TWMSetText);
begin
Inherited;
TitleBar(Active);
end;
procedure TForm1.TitleBar(Act: Boolean);
VAR
TF : TLogFont;
R : Double;
N, X, Y : Integer;
begin
IF Center.X = 0 THEN Exit;
WITH Canvas DO
begin
Brush.Style := bsSolid;
Brush.Color := TitlColors[Act];
PaintRgn(Handle, rTitleBar);
R := RL;
Brush.Color := TitlColors[Act];
Font.Name := 'Arial';
Font.Size := 12;
Font.Color := TxtColors[Act];
Font.Style := [fsBold];
GetObject(Font.Handle, SizeOf(TLogFont), @TF);
FOR N := 1 TO Length(Caption) DO
BEGIN
X := Center.X-Round((Center.X-6)*Sin(R));
Y := Center.Y-Round((Center.Y-6)*Cos(R));
TF.lfEscapement := Round(R * 1800 / pi);
Font.Handle := CreateFontIndirect(TF);
TextOut(X, Y, Caption[N]);
R := R - (((TextWidth(Caption[N]))+2) / Center.X);
IF R < RR THEN Break;
END;
Font.Name := 'MS Sans Serif';
Font.Size := 8;
Font.Color := clWindowText;
Font.Style := [];
end;
end;
procedure TForm1.FormPaint(Sender: TObject);
begin
WITH Canvas DO
BEGIN
Pen.Color := clBlack;
Brush.Style := bsClear;
Pen.Width := 1;
Pen.Color := clWhite;
Arc(1, 1, Width-1, Height-1, Width, 0, 0, Height);
Arc((Width DIV 4)-1, (Height DIV 4)-1,
3*(Width DIV 4)+1, 3*(Height DIV 4)+1, 0, Height, Width, 0);
Pen.Color := clBlack;
Arc(1, 1, Width-1, Height-1, 0, Height, Width, 0);
Arc((Width DIV 4)-1, (Height DIV 4)-1,
3*(Width DIV 4)+1, 3*(Height DIV 4)+1, Width, 0, 0, Height);
TitleBar(Active);
END;
end;
end.
Как получить короткий путь файла если имеется длинный ("c:\Program Files" ==>"c:\progra~1") |
* |
* |
|
Данная опеоация выполняется при помощи функции API GetShortPathName(), которая
получает длинное имя, а возвращает короткое
Как создать свою кнопку в заголовке формы (на Caption Bar) |
* |
* |
|
Непосредственно такой функции вроде нет, но
можно изловчиться. Нарисовать там кнопку вручную
и обрабатывать команды нажатия мышки на Caption Bar.
Пример.
unit Main;
interface
uses
Windows, Buttons, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;
type
TForm1 = class(TForm)
procedure FormResize(Sender: TObject);
private
CaptionBtn : TRect;
procedure DrawCaptButton;
procedure WMNCPaint(var Msg : TWMNCPaint); message WM_NCPaint;
procedure WMNCActivate(var Msg : TWMNCActivate); message WM_NCACTIVATE;
procedure WMSetText(var Msg : TWMSetText); message WM_SETTEXT;
procedure WMNCHitTest(var Msg : TWMNCHitTest); message WM_NCHITTEST;
procedure WMNCLButtonDown(var Msg : TWMNCLButtonDown); message WM_NCLBUTTONDOWN;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
const
htCaptionBtn = htSizeLast + 1;
{$R *.DFM}
procedure TForm1.DrawCaptButton;
var
xFrame, yFrame, xSize, ySize : Integer;
R : TRect;
begin
//Dimensions of Sizeable Frame
xFrame := GetSystemMetrics(SM_CXFRAME);
yFrame := GetSystemMetrics(SM_CYFRAME);
//Dimensions of Caption Buttons
xSize := GetSystemMetrics(SM_CXSIZE);
ySize := GetSystemMetrics(SM_CYSIZE);
//Define the placement of the new caption button
CaptionBtn := Bounds(Width - xFrame - 4*xSize + 2,
yFrame + 2, xSize - 2, ySize - 4);
//Get the handle to canvas using Form's device context
Canvas.Handle := GetWindowDC(Self.Handle);
Canvas.Font.Name := 'Symbol';
Canvas.Font.Color := clBlue;
Canvas.Font.Style := [fsBold];
Canvas.Pen.Color := clYellow;
Canvas.Brush.Color := clBtnFace;
try
DrawButtonFace(Canvas, CaptionBtn, 1, bsAutoDetect, False, False, False);
//Define a smaller drawing rectangle within the button
R := Bounds(Width - xFrame - 4 * xSize + 2,
yFrame + 3, xSize - 6, ySize - 7);
with CaptionBtn do
Canvas.TextRect(R, R.Left + 2, R.Top - 1, 'W');
finally
ReleaseDC(Self.Handle, Canvas.Handle);
Canvas.Handle := 0;
end;
end;
procedure TForm1.WMNCPaint(var Msg : TWMNCPaint);
begin
inherited;
DrawCaptButton;
end;
procedure TForm1.WMNCActivate(var Msg : TWMNCActivate);
begin
inherited;
DrawCaptButton;
end;
procedure TForm1.WMSetText(var Msg : TWMSetText);
begin
inherited;
DrawCaptButton;
end;
procedure TForm1.WMNCHitTest(var Msg : TWMNCHitTest);
begin
inherited;
with Msg do
if PtInRect(CaptionBtn, Point(XPos - Left, YPos - Top)) then
Result := htCaptionBtn;
end;
procedure TForm1.WMNCLButtonDown(var Msg : TWMNCLButtonDown);
begin
inherited;
if (Msg.HitTest = htCaptionBtn) then
ShowMessage('You hit the button on the caption bar');
end;
procedure TForm1.FormResize(Sender: TObject);
begin
//Force a redraw of caption bar if form is resized
Perform(WM_NCACTIVATE, Word(Active), 0);
end;
end.
Если Вам понравился мой сайт, то Вы можете проголосовать за него на Golden URL (заранее спасибо)
Я советую посетить и другие сайты, посвященные программированию. Это легко сделать по кольцу:
Algorithm project
: Кольцо сайтов, посвященных
программированию (подробнее о
проекте WebRing...) [ Предыдущие 5 сайтов | Предыдуший | Следующий | Следующие 5 сайтов | Выбрать сайт случайным образом | Список всех сайтов ]