:: MVP ::
|
|
:: RSS ::
|
|
|
Как ограничить перемещение формы пределами рабочей области?
type
TWmMoving = record
Msg: Cardinal;
fwSide: Cardinal;
lpRect: PRect;
Result: Integer;
end;
type
TForm1 = class(TForm)
private
procedure WMMoving(var Msg: TWMMoving); message WM_MOVING;
{...}
end;
procedure TForm1.WMMoving(var Msg: TWMMoving);
var
WorkArea: TRect;
begin
WorkArea := Screen.WorkareaRect;
with Msg.DragRect^ do
begin
if Left < WorkArea.Left then
OffsetRect(Msg.DragRect^, workArea.Left - Left, 0);
if Top < WorkArea.Top then
OffsetRect(Msg.DragRect^, 0, workArea.Top - Top);
if Right > workArea.Right then
OffsetRect(Msg.DragRect^, workArea.Right - Right, 0);
if Bottom > workArea.Bottom then
OffsetRect(Msg.DragRect^, 0, workArea.Bottom - Bottom);
end;
inherited;
end;
|
Как включить/отключить анимацию формы при сворачивании/разворачивании?
procedure SetAnimation(Value: Boolean);
var
Info: TAnimationInfo;
begin
ZeroMemory(@Info, SizeOf(Info));
Info.cbSize := SizeOf(TAnimationInfo);
BOOL(Info.iMinAnimate) := Value;
SystemParametersInfo(SPI_SETANIMATION, SizeOf(Info), @Info, 0);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
SetAnimation(False); // отключить анимацию
// SetAnimation(True); // включить анимацию
end;
|
Как анимировать появление/скрытие окна?
procedure TForm1.FormShow(Sender: TObject);
begin
AnimateWindow(Handle, 500, AW_CENTER or AW_SLIDE or AW_ACTIVATE);
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
AnimateWindow(Handle, 500, AW_BLEND or AW_HIDE or AW_ACTIVATE);
end;
// При использовании слайда или прокрутки мультипликации необходимо задать направление.
// Это может быть или AW_HOR_POSITIVE, AW_HOR_NEGATIVE, AW_VER_POSITIVE, или AW_VER_NEGATIVE.
// Флажки AW_HOR_POSITIVE или AW_HOR_NEGATIVE можно комбинировать с AW_VER_POSITIVE или AW_VER_NEGATIVE,
// чтобы анимировать окно по диагонали.
|
Как вывести окно на передний план?
// Способ первый
procedure TForm1.ForegroundWnd;
var
ID: Cardinal;
begin
ID := GetWindowThreadProcessId(GetForegroundWindow, nil);
AttachThreadInput(GetCurrentThreadId, ID, True);
SetForegroundWindow(Handle);
AttachThreadInput(GetCurrentThreadId, ID, False);
if IsIconic(Handle) then
ShowWindow(Handle, SW_RESTORE);
end;
// Способ второй
procedure SwitchToThisWindow(Wnd: HWND; fAltTab: Boolean);
stdcall; external 'user32.dll' name 'SwitchToThisWindow';
implementation
procedure TForm1.Button1Click(Sender: TObject);
begin
// SetActiveWindow(Handle);
SwitchToThisWindow(Handle, True);
end;
|
Как перебрать все окна в z-порядке, начиная с верхнего?
procedure GetList(Memo: TMemo);
function GetDesctopHandle: HWND;
begin
Result := FindWindow('Progman', 'Program Manager');
Result := FindWindowEx(Result, HWND(nil), 'SHELLDLL_DefView', '');
Result := FindWindowEx(Result, HWND(nil), 'SysListView32', '');
end;
var
w: HWND;
buff: array [0..MAX_PATH] of Char;
begin
Memo.Clear;
// Получаем окно на вершине z-порядка
w := GetTopWindow(GetDesctopHandle);
while w > 0 do
begin
{if w <> Form1.Handle then} // Можно пропустить собственное окно
if IsWindowVisible(w) and
// Пропускаем окне без заголовков
(GetWindowText(w, buff, SizeOf(buff)) <> 0)
{and not IsIconic(w)} then
begin
GetWindowText(w, buff, SizeOf(buff));
Memo.Lines.Add(StrPas(buff) + #9 + IntToStr(w));
end;
w := GetNextWindow(w, GW_HWNDNEXT);
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
GetList(Memo1);
end;
|
Как сделать, чтобы программа запускалась только один раз за сессию Windows?
procedure TForm1.FormCreate(Sender: TObject);
var
CRLF: string;
begin
if GlobalFindAtom('THIS_IS_SOME_OBSCUREE_TEXT') = 0 then
GlobalAddAtom('THIS_IS_SOME_OBSCUREE_TEXT')
else
begin
CRLF := #10 + #13;
ShowMessage('Эта версия прогаммы может быть запущена ' +
'только один раз за сессию Windows.' + CRLF +
'Чтобы запустить программу снова, ' +
'вам нужно перезагрузить Windows, или' + CRLF +
'Зарегистрироваться !!!');
Halt;
end;
end;
|
Как сделать, чтобы форма отбрасывала тень?
// Это хорошо смотрится в Win2000/XP, в Vista/7 лучше не использовать
procedure TForm1.FormCreate(Sender: TObject);
const
CS_DROPSHADOW = $20000; // Могут быть и другие значения - $20001, $20005, ...
begin
SetClassLong(Handle, GCL_STYLE, GetWindowLong(Handle, GCL_STYLE) or CS_DROPSHADOW);
end;
|
Как запретить переход фокуса при нажатии клавиши TAB?
type
TForm1 = class(TForm)
private
procedure CMDialogKey(var Msg: TWMKey); message CM_DIALOGKEY;
end;
procedure TForm1.CMDialogKey(var Msg: TWMKey);
begin
// При желании для определенных компонентов можно сделать исключение
// if not (ActiveControl is TButton) then
if Msg.Charcode = VK_TAB then
Msg.Charcode := 0;
inherited;
end;
|
Как изменить размер формы, не имеющей границ?
// Способ первый
type
TForm1 = class(TForm)
private
procedure HitTest(var Msg: TWMNcHitTest); message WM_NCHITTEST;
end;
{...}
implementation
{...}
procedure TForm1.HitTest(var Msg: TWMNcHitTest);
var
x, y: Integer;
begin
inherited;
x := Msg.XPos - Left;
y := Msg.YPos - Top;
if x <= 4 then
begin
if y <= 4 then
Msg.Result := HTTOPLEFT
else
if y >= ClientHeight - 4 then
Msg.Result := HTBOTTOMLEFT
else
Msg.Result := HTLEFT;
end
else
if y <= 4 then
begin
if x >= ClientWidth - 4 then
Msg.Result := HTTOPRIGHT
else
Msg.Result := HTTOP;
end
else
if y >= ClientHeight - 4 then
begin
if x >= ClientWidth - 4 then
Msg.Result := HTBOTTOMRIGHT
else
Msg.Result := HTBOTTOM;
end
else
if x >= ClientWidth - 4 then
Msg.Result := HTRIGHT
else
Msg.Result := HTCAPTION;
end;
// Способ второй
type
TForm1 = class(TForm)
public
procedure CreateParams(var Params: TCreateParams); override;
end;
{...}
implementation
{...}
procedure TForm1.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
Params.Style := Params.Style or WS_SIZEBOX;
// Params.ExStyle:= Params.ExStyle or WS_EX_STATICEDGE
end;
|
При использовании материала - ссылка на сайт обязательна
|
|