FAQ по Delphi
"Добавление пункта в системное меню Windows"
-----------------------------------------------------------------------
Type
TForm1 = Class (TForm)
Procedure FormCreate (Sender : TObject);
Private
{Private declarations}
Public
{Public declarations}
Procedure WinMsg (Var Msg : TMsg; Var Handled : Boolean);
Procedure DoWhatEever;
End;
Var
Form1 : TForm1;
Implementation
{$R *.DFM}
Const
ItemID = 99;
Procedure Tform1.WinMsg (Var Msg : TMsg; Var Handled : Boolean);
Begin
If Msg.Message = WM_SYSCOMMAND Then
If Msg.WParam = ItemID Then DoWhatEver;
End;
Procedure TForm1.FormCreate (Sender : TObject);
Begin
Application.OnMessage := WinMsg;
AppendMenu (GetSystemMenu (Form1.Handle, False), MF_SEPARATOR, 0, '');
AppendMenu (GetSystemMenu (Form1.Handle, False), MF_BYPOSITION, ItemID, '&My
menu');
AppendMenu (GetSystemMenu (Application.Handle, False), MF_SEPARATOR, 0, '');
AppendMenu (GetSystemMenu (Application.Handle, False), MF_BYPOSITION, ItemID,'&My
menu minimized');
End;
Procedure TForm1.DoWhatEver;
Begin
Exit;
End;
End.
-----------------------------------------------------------------------
"Получение списка запущенных приложений"
-----------------------------------------------------------------------
procedure TForm1.Button1Click(Sender: TObject);
VAR
Wnd : HWnd;
Buff: ARRAY [0..127] Of Char;
begin
ListBox1.Clear;
Wnd := GetWindow(Handle, GW_HWndFirst);
WHILE Wnd <> 0 Do
Begin
IF (Wnd <> Application.Handle) AND
IsWindowVisible(Wnd) AND
(GetWindow(Wnd, gw_Owner) = 0) AND
(GetWindowText(Wnd, Buff, SizeOf(Buff)) <> 0) Then
Begin
GetWindowText(Wnd, Buff, Sizeof(buff));
ListBox1.Items.Add(StrPas(buff));
END;
Wnd := GetWindow(Wnd, gw_hWndNext);
END;
ListBox1.ItemIndex := 0;
end;
-----------------------------------------------------------------------
"Выполнение встроенных команд Windows"
-----------------------------------------------------------------------
В операционной системе Microsoft Windows существует множество зарезирвированных
команд, которые можно вызыват с помощью простой
функции WinExec.
-----------------------------------------------------------------------
WinExec(PChar('ABCD'), SW_Show);
- где 'ABCD' - одна из следующих команд ...
"rundll32 shell32,Control_RunDLL" - Запустить Панель Управления
"rundll32 shell32,OpenAs_RunDLL" - Открыть диалог "Открыть Как ..." ('Open
With...')
"rundll32 shell32,ShellAboutA Info-Box" - Открыть 'About Window Window'
"rundll32 shell32,Control_RunDLL desk.cpl" - Открыть диалог "Свойства: Экран"
(Display Properties)
"rundll32 user,cascadechildwindows" - Выстроить все окна каскадно
"rundll32 user,tilechildwindows" - Свернуть все окна
"rundll32 user,repaintscreen" - Обновить Десктоп
"rundll32 shell,shellexecute Explorer" - Перезапустить Проводник
"rundll32 keyboard,disable" - Заблокировать Клавиатуру
"rundll32 mouse,disable" - Запретить мышку
"rundll32 user,swapmousebutton" - Поменять кнопки мыши
"rundll32 user,setcursorpos" - Установить Курсор в позицию (0,0)
"rundll32 user,wnetconnectdialog" - Показать диалог "Подключить сетевой диск"
('Map Network Drive')
"rundll32 user,wnetdisconnectdialog" - Показать диалог "Отключить сетевой диск"
('Disconnect Network Disk')
"rundll32 user,disableoemlayer" - Отобразить окно BSOD ('''(BSOD) = Blue Screen
Of Death ''')
"rundll32 diskcopy,DiskCopyRunDll" - Показать диалог копирования диска
"rundll32 rnaui.dll,RnaWizard" - Запустить 'Internet Connection Wizard'
"rundll32 shell32,SHFormatDrive" - Запустить окно форматирования дискеты
('Format Disk (A)')
"rundll32 shell32,SHExitWindowsEx -1" - "Холодный" перезапуск Проводника
"rundll32 shell32,SHExitWindowsEx 1" - Выключить компьютер
"rundll32 shell32,SHExitWindowsEx 0" - Завершить сеанс текущего пользователя
"rundll32 shell32,SHExitWindowsEx 2" Быстрый перезапуск Windows9x
"rundll32 krnl386.exe,exitkernel" - Выход из Windows 9x без потверждения
"rundll rnaui.dll,RnaDial "MyConnect" - Запустить диалог 'Net Connection'
"rundll32 msprint2.dll,RUNDLL_PrintTestPage" - Выбор и печать тестовой страницы
текущего принтера
"rundll32 user,setcaretblinktime" - Усатновить скорость мигания курсора
"rundll32 user, setdoubleclicktime" - Установить скорость двойного нажатия
"rundll32 sysdm.cpl,InstallDevice_Rundll" - Поиск устройств не PnP.
-----------------------------------------------------------------------
"Drag&Drop для файлов"
-----------------------------------------------------------------------
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
type
TForm1 = class(TForm)
Memo1: TMemo;
procedure FormCreate(Sender: TObject);
private
procedure WMDROPFILES(var Message: TWMDROPFILES);
message WM_DROPFILES;
public
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
uses ShellApi;
procedure TForm1.FormCreate(Sender: TObject);
begin
DragAcceptFiles(Form1.Handle, True);
end;
procedure TForm1.WMDROPFILES(var Message: TWMDROPFILES);
var
NumFiles : longint;
i : longint;
buffer : array[0..255] of char;
begin
NumFiles := DragQueryFile(Message.Drop, -1, nil, 0);
for i := 0 to (NumFiles - 1) do begin
DragQueryFile(Message.Drop, i, @buffer, SizeOf(buffer));
Form1.Memo1.Lines.Add(buffer);
end;
end;
end.
-----------------------------------------------------------------------
"Рисование на определеннной области экрана"
-----------------------------------------------------------------------
Вопрос о том, можно ли из Delphi рисовать в любой части экрана или в чужом окне,
встречается довольно часто. Можно. Все это делается с помощью API функции:
function GetDC(Wnd: HWND): HDC;
- где WND - указательна чужое окно (0 - для всего экрана);
PROCEDURE DrawOnScreen;
VAR ScreenDC: hDC;
BEGIN
ScreenDC := GetDC(0); {получить контекст экрана}
Ellipse(ScreenDC, 0, 0, 200, 200); {нарисовать}
ReleaseDC(0,ScreenDC); {освободить контекст}
END;
Не забывайте после своих манипуляций посылать пострадавшим (или всем) окнам
сообщение о необходимости перерисовки, для восстановления их первоначального
вида.
-----------------------------------------------------------------------
"Определения присутствия диска в системе"
-----------------------------------------------------------------------
Очень часто требуется определить сущестование в системе диска под
определенной буквой или цифрой. Ниже приведен один простой пример,
который позволяет это сделать.
function DriveExists(Drive: Byte): Boolean;
begin
Result := Boolean (GetLogicalDrives And (1 shl Drive));
end;
-----------------------------------------------------------------------
"Эффектное появление окна"
-----------------------------------------------------------------------
procedure TForm1.FormShow(Sender: TObject);
var
RectSmall,RectNormal:TRect;
begin
RectSmall:=Rect(0,0,0,0);
RectNormal:=Form1.BoundsRect;
DrawAnimatedRects(GetDesktopWindow,IDANI_CAPTION,RectSmall,
RectNormal);
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
var
RectSmall,RectNormal:TRect;
begin
RectSmall:=Rect(0,0,0,0);
RectNormal:=Form1.BoundsRect;
DrawAnimatedRects(GetDesktopWindow,IDANI_CAPTION,RectNormal,
RectSmall);
end;
-----------------------------------------------------------------------
"Манипуляция лампочками на клавиатуре"
-----------------------------------------------------------------------
procedure SetNumLock(bState:Boolean);
var
KeyState : TKeyboardState;
begin
GetKeyboardState(KeyState);
if ( (bState) and (not ((KeyState[VK_NUMLOCK] and 1)=1) ) or
( (not (bState)) and ((KeyState[VK_NUMLOCK] and 1)=1))) then
keybd_event(VK_NUMLOCK, $45, (KEYEVENTF_EXTENDEDKEY or 0), 0);
keybd_event( VK_NUMLOCK, $45, (KEYEVENTF_EXTENDEDKEY or
KEYEVENTF_KEYUP), 0);
end;
-----------------------------------------------------------------------
"Затемнение экрана"
-----------------------------------------------------------------------
Часто пользователи спрашивают о том, каким образом можно затемнить экран (как
при Завершении Работы).
procedure GrayDesktop();
const
Color1 = clWhite;
Color2 = clBlack;{}
{Color1 = $00AAAAAA;
Color2 = $00555555;{}
var
DesktopDC, MemDC: HDC;
NewBitmap, OldBitmap: HBITMAP;
I, J: Integer;
begin
DesktopDC := GetDC(0);
try
MemDC := CreateCompatibleDC(DesktopDC);
if MemDC <>0 then
begin
NewBitmap := CreateCompatibleBitmap(DesktopDC, 32, 32);
if NewBitmap <>0 then
begin
OldBitmap := SelectObject(MemDC, NewBitmap);
for I := 0 to 31 do
for J := 0 to 31 do
if (I + J) and 1 = 0 then
SetPixel(MemDC, I, J, Color1)
else
SetPixel(MemDC, I, J, Color2);
{ Paint }
J := 0;
while J <Screen.Height do
begin
I := 0;
while I <Screen.Width do
begin
BitBlt(DesktopDC, I, J, 32, 32, MemDC, 0, 0, SRCAND);
Inc(I, 32);
end;
Inc(J, 32);
end;
{ Delete objects }
DeleteObject(NewBitmap);
SelectObject(MemDC, OldBitmap);
end;
DeleteDC(MemDC);
end;
finally
ReleaseDC(0, DesktopDC);
end;
end;
-----------------------------------------------------------------------
"Неактивная кнопка X"
-----------------------------------------------------------------------
procedure TForm1.FormCreate(Sender: TObject);
var
hMenuHandle: HMENU;
begin
hMenuHandle := GetSystemMenu(Handle, FALSE);
IF (hMenuHandle <> 0) THEN
DeleteMenu(hMenuHandle, SC_CLOSE, MF_BYCOMMAND);
end;
-----------------------------------------------------------------------
"Имитирование нажатия клавиши мыши"
-----------------------------------------------------------------------
procedure TForm1.Timer1Timer(Sender: TObject);
var
X,Y: Integer;
begin
X := Random(300);
Y := Random(200);
SendMessage(Handle, WM_LBUTTONDOWN, MK_LBUTTON, X+Y shl 16);
SendMessage(Handle, WM_LBUTTONUP, MK_LBUTTON, X+Y shl 16);
end;
procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
Label1.Caption := InttoStr(X) + ',' + IntToStr(Y);
Label1.Left := X;
Label1.Top := Y;
end;
-----------------------------------------------------------------------
"Помещение иконки в Tray-панели"
-----------------------------------------------------------------------
Для решения данной проблемы создано очень много соответствующих
компонентов, которые без единой строчки кода добавляют любую
пиктограмму в системную панель. Но, не мешает знать сам принцип
помещения иконки в Tray-панель.
-----------------------------------------------------------------------
procedure TForm1.Button1Click(Sender: TObject);
{
Добавление иконки
}
var
No : TNotifyIconData;
TrIcon: HIcon;
begin
TrIcon := ExtractIcon(Handle, 'C:\Cursor.ico', 0);
With No do
begin
cbSize := Sizeof(TNotifyIconData);
Wnd := Handle;
uID := 0;
UFlags := NIF_MESSAGE + NIF_ICON + NIF_TIP;
SzTip := 'Traybar Tip';
HIcon := TrIcon;
uCallBackMessage := WM_USER + 0;
end;
Shell_NotifyIcon(Nim_Add, @no);
end;
procedure TForm1.Button2Click(Sender: TObject);
{
Удаление иконки
}
var
No: TNotifyIconData;
begin
With No do
begin
cbSize := Sizeof(TNotifyIconData);
Wnd := Handle;
uID := 0;
end;
Shell_NotifyIcon(Nim_Delete, @No);
end;
-----------------------------------------------------------------------
