FAQs
Программное
выключение монитора.
Мигающий заголовок
окна.
Закрытие всплывающего
меню в приложении system tray.
Текущее время и дата по
Гринвичу.
Способ быстрой очистки
canvasа .
Использование
InvalidateRect()t для перерисовки всей
формы.
Использование
процедуры mouse_event() .
Программное закрытие
другого приложения.
Форматирование диска.
Отключение кнопки
'Пуск'.
Отключение обновления
окна.
Программная установка
драйвера принтера.
Как набрать номер с
помощью модема в Win32.
Использование Tapi (Telephony
API).
Показ иконки,
ассоциированной с данным типом
файла.
Определение нажатия
определенной клавиши во время
загрузки приложения.
Звуки из динамика.
Отключение кнопки
закрытия любого окна.
Как узнать путь к
каталогам Windows.
Как узнать полный путь
и имя файла загруженной DLL.
Вызов диалога 'Найти
файлы и паки' проводника.
MDI - родительское окно с
фоновым рисунком.
Как перехватить
нажатие кнопки PrintScreen в Windows.
Определение числа
заданий spoolerа печати.
Как определить имена
установленых Com-портов.
Извлечение
пиктограммы из exe, dll или ico-файла.
Обновление Рабочего
Стола Windows.
Отключение
перерисовки содержимого окна при
перемещении.
Передача процессорных
циклов другим приложениям.
Запуск программы на
старте Windows.
Увеличение
процессорного времени, выделяемого
программе.
Определение момента
окончания изменения размера окна.
Определение времени
последнего доступа к файлу.
Использование функции
Shell API SHBrowseForFolder.
Получение дескриптора
окна Window, сожержащего DOS программу.
Определение факта
изменения системного времени.
Очистка пункта
Документы меню кнопки Пуск .
Опеределение
состояния модема под Win32.
Добавление пункта к
системному меню.
Создание
нестандартной процедуры разбиения
слов.
Копирование файлов,
используя стандартный диалог
Копирование Файла Windows.
Как узнать серийный
номер диска.
Как узнать тип диска.
Проверка готовности
диска.
Использование FindFirst
для поиска файлов.
Получение дескриптора
окна другого приложения.
Создание не-VCL
консольного поекта.
Ошибка внешней функции
при передаче параметров типа boolean.
Как получить длинное
имя файла .
Временное отключение
range checking .
Получение имени файла
и пути локальной таблицы.
Получение дескриптора
панели задач (TaskBar).
Запуск Screen saver'а
програмно.
Установлены ли TrueType
шрифты.
Как послать файл в
корзину.
Обои рабочего стола.
Запущен ли Delphi.
Версия Windows.
Переменные окружения
DOS.
Рисовать на Рабочем
столе.
Каталог Windows.
Размер Рабочего стола.
Как закрыть CD.
Определение
свободного дискового пространства.
Как спрятать Windows Taskbar.
Машина в сети.
Добавить документ в
меню ПУСК ДОКУМЕНТЫ.
Изменить порт
принтера.
Определить измения
оборудования PlugNPlay.
Изменения в ini-файле.
Как открыть
Проводником кокретный каталог.
Запустить аплет панели
управления.
Цветная печать.
Открыть URL
установленным браузером.
Стереть ехе-файл во
время выполнения.
Програмно добавить
шрифты True Type.
Часовые пояса.
Использование функции
GetTimeZoneInformation.
Прозрачный текст.
Информация о версии
файла.
Как создать иконку из
bitmap'а.
Преобразование цвета в
оттенки серого.
Как держать приложение
в минимизированном виде.
Вызов функции RegisterClass .
drag &drop файлов.
Создание задержки без
таймера.
Перезапуск Windows.
Вопрос:
Как программно выключить монитор?
Ответ:
Программно можно отключить монитор
совместимый со стандартом EnergyStar.
Отправьте сообщение wm_SysCommand с
параметром WParam = SC_MonitorPower
и LParam = 0 для отключения монитора LParam = 1 для включения монитора
В приведенном примере монитор
отключается на 10 секунд.
Пример:
type TForm1 = class(TForm) Button1: TButton; Timer1: TTimer; procedure FormCreate(Sender: TObject); procedure Timer1Timer(Sender: TObject); procedure Button1Click(Sender: TObject); private { Private declarations } public MonitorOff : bool; { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.FormCreate(Sender: TObject); begin Timer1.Enabled := false; Timer1.Interval := 10000; MonitorOff := false; end; procedure TForm1.Timer1Timer(Sender: TObject); begin if MonitorOff then begin MonitorOff := false; SendMessage(Application.Handle, wm_SysCommand, SC_MonitorPower, -1); Timer1.Enabled := false; end; end; procedure TForm1.Button1Click(Sender: TObject); begin MonitorOff := true; Timer1.Enabled := true; SendMessage(Application.Handle, wm_SysCommand, SC_MonitorPower, 0); end;
Вопрос:
Как создать мигающий заголовок
окна (пиктограмму)?
Ответ:
Можно воспользоваться функцией API
FlashWindow():
Пример:
var Flash : bool; procedure TForm1.Timer1Timer(Sender: TObject); begin FlashWindow(Form1.Handle, Flash); FlashWindow(Application.Handle, Flash); Flash := not Flash; end; procedure TForm1.FormCreate(Sender: TObject); begin Flash := False; end;
Вопрос:
Иногда всплывающее меню моего
приложения system tray не исчезает когда
оно теряет фокус. Как закрыть его?
Ответ:
При показе всплывающего меню
установите foreground window, затем пошлите
сообщение WM_NULL после показа меню.
procedure TForm1.WndProc(var Msg : TMessage); var p : TPoint; begin case Msg.Msg of WM_USER + 1: case Msg.lParam of WM_RBUTTONDOWN: begin SetForegroundWindow(Handle); GetCursorPos(p); PopupMenu1.Popup(p.x, p.y); PostMessage(Handle, WM_NULL, 0, 0); end; end; end; inherited; end;
Вопрос:
Как узнать текущие время и дату по
Гринвичу
Ответ:
Используя API фукцию GetSystemTime.
Пример:
procedure TForm1.Button1Click(Sender: TObject); var lt : TSYSTEMTIME; st : TSYSTEMTIME; begin GetLocalTime(lt); GetSystemTime(st); Memo1.Lines.Add('LocalTime = ' + IntToStr(lt.wmonth) + '/' + IntToStr(lt.wDay) + '/' + IntToStr(lt.wYear) + ' ' + IntToStr(lt.wHour) + ':' + IntToStr(lt.wMinute) + ':' + IntToStr(lt.wSecond)); Memo1.Lines.Add('UTCTime = ' + IntToStr(st.wmonth) + '/' + IntToStr(st.wDay) + '/' + IntToStr(st.wYear) + ' ' + IntToStr(st.wHour) + ':' + IntToStr(st.wMinute) + ':' + IntToStr(st.wSecond)); end;
Вопрос:
Какой самый быстрый способ для
очистки canvasа?
Ответ:
Windows API функция PatBlt().
Пример:
procedure TForm1.Button1Click(Sender: TObject); begin PatBlt(Form1.Canvas.Handle, 0, 0, Form1.ClientWidth, Form1.ClientHeight, WHITENESS); end;
Вопрос:
При изменении размеров формы мне
необходимо чтобы перерисовывалась
вся ее поверхность. Но свойство
Canvas.ClipRect у формы - только для чтения.
Ответ:
На событии Resize вызовите Windows API
функцию InvalidateRect(). Если передать nil в
качестве второго параметра
приведет к тому, что
перерисовываться будет вся
клиентская область окна. Третий
параметр указывает будет ли
перерисовываться фон формы.
Пример:
procedure TForm1.FormResize(Sender: TObject); begin InvalidateRect(Form1.Handle, nil, false); end;
Вопрос:
Как использовать процедуру mouse_event()
для имитации событий мыши?
Ответ:
Приведенный пример демонстрирует
использование API функции mouse_event()
для имитации событий мыши. При
нажатии кнопки Button2 программа
перемещает курсор мыши на кнопку
Button1 и щелкает по ней. Положение
курсора мыши задается в
"абсолютных" координатах
("Mickeys"), где 65535 "Mickeys"
равно ширине экрана.
procedure TForm1.Button1Click(Sender: TObject); begin ShowMessage('Button 1 clicked'); end; procedure TForm1.Button2Click(Sender: TObject); var Pt : TPoint; begin {Позволим кнопке Button2 перерисоваться} Application.ProcessMessages; {Найдем координаты центра button 1} Pt.x := Button1.Left + (Button1.Width div 2); Pt.y := Button1.Top + (Button1.Height div 2); {Преобразуем Pt к координатам экрана} Pt := ClientToScreen(Pt); {Преобразуем Pt к "mickeys" (аболютным координатам курсора мышки} Pt.x := Round(Pt.x * (65535 / Screen.Width)); Pt.y := Round(Pt.y * (65535 / Screen.Height)); {Переместим курсор мыши} Mouse_Event(MOUSEEVENTF_ABSOLUTE or MOUSEEVENTF_MOVE, Pt.x, Pt.y, 0, 0); {Имитируем нажатие левой кнопки мыши} Mouse_Event(MOUSEEVENTF_ABSOLUTE or MOUSEEVENTF_LEFTDOWN, Pt.x, Pt.y, 0, 0);; {Имитируем отпускание левой кнопки мыши} Mouse_Event(MOUSEEVENTF_ABSOLUTE or MOUSEEVENTF_LEFTUP, Pt.x, Pt.y, 0, 0);; end;
Вопрос:
Как программно закрыть другое
приложение?
Ответ:
Отправьте этому приложению
сообщение WM_QUIT
Пример:
PostMessage(FindWindow(Nil, 'Заголовок окна'), WM_QUIT, 0, 0); Где "Заголовок окна" - заголовок окна, которому Вы посылаете сообщение.
Вопрос:
Форматирование диска в Win32
Ответ:
ShellAPI функция ShFormatDrive().
Пример:
const SHFMT_DRV_A = 0; const SHFMT_DRV_B = 1; const SHFMT_ID_DEFAULT = $FFFF; const SHFMT_OPT_QUICKFORMAT = 0; const SHFMT_OPT_FULLFORMAT = 1; const SHFMT_OPT_SYSONLY = 2; const SHFMT_ERROR = -1; const SHFMT_CANCEL = -2; const SHFMT_NOFORMAT = -3; function SHFormatDrive(hWnd : HWND; Drive : Word; fmtID : Word; Options : Word) : Longint stdcall; external 'Shell32.dll' name 'SHFormatDrive'; procedure TForm1.Button1Click(Sender: TObject); var FmtRes : longint; begin try FmtRes:= ShFormatDrive(Handle, SHFMT_DRV_A, SHFMT_ID_DEFAULT, SHFMT_OPT_QUICKFORMAT); case FmtRes of SHFMT_ERROR : ShowMessage('Error formatting the drive'); SHFMT_CANCEL : ShowMessage('User canceled formatting the drive'); SHFMT_NOFORMAT : ShowMessage('No Format') else ShowMessage('Disk has been formatted'); end; except end; end;
Вопрос:
Как спрятать и отключить кнопку
"Пуск"?
Ответ:
Приведенный пример прячет и
показывает кнопку "Пуск", а
также разрешает и запрещает ее.
Пример:
procedure TForm1.Button1Click(Sender: TObject); var Rgn : hRgn; begin {Cпрятать кнопку "Пуск"} Rgn := CreateRectRgn(0, 0, 0, 0); SetWindowRgn(FindWindowEx(FindWindow('Shell_TrayWnd', nil), 0, 'Button', nil), Rgn, true); end; procedure TForm1.Button2Click(Sender: TObject); begin {Показать кнопку "Пуск"} SetWindowRgn(FindWindowEx(FindWindow('Shell_TrayWnd', nil), 0, 'Button', nil), 0, true); end; procedure TForm1.Button3Click(Sender: TObject); begin {Запретить кнопку "Пуск"} EnableWindow(FindWindowEx(FindWindow('Shell_TrayWnd', nil), 0, 'Button', nil), false); end; procedure TForm1.Button4Click(Sender: TObject); begin {Разрешить кнопку "Пуск"} EnableWindow(FindWindowEx(FindWindow('Shell_TrayWnd', nil), 0, 'Button', nil), true); end
Вопрос:
Как временно отключить перерисовку
окна?
Ответ:
Вызовите функцию WinAPI LockWindowUpdate
передав ей дескриптор окна, которое
необходимо не обновлять. Передайте
ноль в качестве параметра для
восстановления нормального
обновления.
LockWindowUpdate(Memo1.Handle); . . LockWindowUpdate(0);
Вопрос:
Моя программа использует дравер
принтера. Возможно ли потихоньку
установить драйвер принтера без
вмешательства пользователя?
Ответ:
Приведенный пример устанавливает
драйвер принтера. Вам необходимо
скопировать файлы с драйвером
принтера в каталог Windows\System и внести
необходимые изменения в файл Win.Ini.
Примечание: DriverName = Имя драйвера; DRVFILE - имя файла с драйвером без расширения (".drv" - по умолчанию).
Пример:
procedure TForm1.Button1Click(Sender: TObject); var s : array[0..64] of char; begin WriteProfileString('PrinterPorts', 'DriverName', 'DRVFILE,FILE:,15,45'); WriteProfileString('Devices', 'DriverName', 'DRVFILE,FILE:'); StrCopy(S, 'PrinterPorts'); SendMessage(HWND_BROADCAST, WM_WININICHANGE, 0, LongInt(@S)); StrCopy(S, 'Devices'); SendMessage(HWND_BROADCAST, WM_WININICHANGE, 0, LongInt(@S)); end;
Вопрос:
Как набрать номер с помощью модема
в Win32?
Ответ:
Используйте функцию Windows API CreateFile()
чтобы получить дескриптор порта, и
стандартные функции ввода-вывода
для связи с полученным портом.
Пример:
var hCommFile : THandle; procedure TForm1.Button1Click(Sender: TObject); var PhoneNumber : string; CommPort : string; NumberWritten : LongInt; begin PhoneNumber := 'ATDT 1-555-555-1212' + #13 + #10; CommPort := 'COM2'; {Open the comm port} hCommFile := CreateFile(PChar(CommPort), GENERIC_WRITE, 0, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0); if hCommFile=INVALID_HANDLE_VALUE then begin ShowMessage('Unable to open '+ CommPort); exit; end; {Dial the phone} NumberWritten:=0; if WriteFile(hCommFile, PChar(PhoneNumber)^, Length(PhoneNumber), NumberWritten, nil) = false then begin ShowMessage('Unable to write to ' + CommPort); end; end; procedure TForm1.Button2Click(Sender: TObject); begin {Close the port} CloseHandle(hCommFile); end;
Вопрос:
Как использовать TAPI для голосового
звонка?
Ответ:
См пример.
Пример:
{tapi Errors} const TAPIERR_CONNECTED = 0; const TAPIERR_DROPPED = -1; const TAPIERR_NOREQUESTRECIPIENT = -2; const TAPIERR_REQUESTQUEUEFULL = -3; const TAPIERR_INVALDESTADDRESS = -4; const TAPIERR_INVALWINDOWHANDLE = -5; const TAPIERR_INVALDEVICECLASS = -6; const TAPIERR_INVALDEVICEID = -7; const TAPIERR_DEVICECLASSUNAVAIL = -8; const TAPIERR_DEVICEIDUNAVAIL = -9; const TAPIERR_DEVICEINUSE = -10; const TAPIERR_DESTBUSY = -11; const TAPIERR_DESTNOANSWER = -12; const TAPIERR_DESTUNAVAIL = -13; const TAPIERR_UNKNOWNWINHANDLE = -14; const TAPIERR_UNKNOWNREQUESTID = -15; const TAPIERR_REQUESTFAILED = -16; const TAPIERR_REQUESTCANCELLED = -17; const TAPIERR_INVALPOINTER = -18; {tapi size constants} const TAPIMAXDESTADDRESSSIZE = 80; const TAPIMAXAPPNAMESIZE = 40; const TAPIMAXCALLEDPARTYSIZE = 40; const TAPIMAXCOMMENTSIZE = 80; const TAPIMAXDEVICECLASSSIZE = 40; const TAPIMAXDEVICEIDSIZE = 40; function tapiRequestMakeCallA(DestAddress : PAnsiChar; AppName : PAnsiChar; CalledParty : PAnsiChar; Comment : PAnsiChar) : LongInt; stdcall; external 'TAPI32.DLL'; function tapiRequestMakeCallW(DestAddress : PWideChar; AppName : PWideChar; CalledParty : PWideChar; Comment : PWideChar) : LongInt; stdcall; external 'TAPI32.DLL'; function tapiRequestMakeCall(DestAddress : PChar; AppName : PChar; CalledParty : PChar; Comment : PChar) : LongInt; stdcall; external 'TAPI32.DLL'; procedure TForm1.Button1Click(Sender: TObject); var DestAddress : string; CalledParty : string; Comment : string; begin DestAddress := '1-555-555-1212'; CalledParty := 'Frank Borland'; Comment := 'Calling Frank'; tapiRequestMakeCall(pChar(DestAddress), PChar(Application.Title), pChar(CalledParty), PChar(Comment)); end; end.
Вопрос:
Как показать иконку,
ассоциированной с данным типом
файла?
Ответ:
ShellApi функция ExtractAssociatedIcon()
Пример:
uses ShellApi; procedure TForm1.Button1Click(Sender: TObject); var Icon : hIcon; IconIndex : word; begin IconIndex := 1; Icon := ExtractAssociatedIcon(HInstance, Application.ExeName, IconIndex); DrawIcon(Canvas.Handle, 10, 10, Icon); end;
Вопрос:
Как определение нажатия
определенной клавиши во время
загрузки приложения?
Ответ:
Используйту WinAPI функцию GetKeyState() для
определения нажатия клавиши в
тексте проекта. Для того чтобы
увидеть текст файла проекта в
главном меню Delphi 3 выберите
"View""ProjectSource" в Delphi 4
"Project""View Source".
Пример:
program Project1; uses Windows, Forms, Unit1 in 'Unit1.pas' {Form1}; {$R *.RES} begin if GetKeyState(vk_F8) < 1 then MessageBox(0, 'F8 was pressed during startup', 'MyApp', mb_ok); Application.Initialize; Application.CreateForm(TForm1, Form1); Application.Run; end.
Вопрос:
Как заставить пикнуть динамик
несколько раз с небольшой
задержкой между сигналами, не
зависящей от тактовой частоты
процессора?
Ответ:
См. пример.
Пример:
procedure Delay(ms : longint); {$IFNDEF WIN32} var TheTime : LongInt; {$ENDIF} begin {$IFDEF WIN32} Sleep(ms); {$ELSE} TheTime := GetTickCount + ms; while GetTickCount
Вопрос:
Можно ли отключить кнопку закрытия
любого окна?
Ответ:
Да, приведенный пример отключает
кнопку закрытия и пункт
"закрыть" ситсемного меню
заданного окна.
procedure TForm1.Button1Click(Sender: TObject); var hwndHandle : THANDLE; hMenuHandle : HMENU; begin hwndHandle := FindWindow(nil, 'Untitled - Notepad'); if (hwndHandle <> 0) then begin hMenuHandle := GetSystemMenu(hwndHandle, FALSE); if (hMenuHandle <> 0) then DeleteMenu(hMenuHandle, SC_CLOSE, MF_BYCOMMAND); end; end;
Вопрос:
Как узнать путь к каталогам Windows?
Ответ:
Следующий пример получает полный
список каталогов по умолчанию
(Favorites, Desktop, Programs, Fonts, SendTo, Start, Menu,
Templates, Startup, Recent and NetHood) Windows и заносит
его в Memo.
Пример:
uses Registry; procedure TForm1.Button1Click(Sender: TObject); var reg : TRegistry; ts : TStrings; i : integer; begin reg := TRegistry.Create; reg.RootKey := HKEY_CURRENT_USER; reg.LazyWrite := false; reg.OpenKey( 'Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders', false); ts := TStringList.Create; reg.GetValueNames(ts); for i := 0 to ts.Count -1 do begin Memo1.Lines.Add(ts.Strings[i] + ' = ' + reg.ReadString(ts.Strings[i])); end; ts.Free; reg.CloseKey; reg.free; end;
Вопрос:
Как узнать полный путь и имя файла
загруженной DLL?
Ответ:
См. пример
Пример:
uses Windows; procedure ShowDllPath stdcall; var TheFileName : array[0..MAX_PATH] of char; begin FillChar(TheFileName, sizeof(TheFileName), #0); GetModuleFileName(hInstance, TheFileName, sizeof(TheFileName)); MessageBox(0, TheFileName, 'The DLL file name is:', mb_ok); end;
Вопрос:
Как вызвать диалог 'Найти файлы и
паки' проводника?
Ответ:
Приведенный пример показывает
использование DDE для вызова диалога
'Найти файлы и паки' Explorerа. Диалог
открывается на каталоге
"C:\Download".
procedure TForm1.Button1Click(Sender: TObject); begin with TDDEClientConv.Create(Self) do begin ConnectMode := ddeManual; ServiceApplication := 'explorer.exe'; SetLink( 'Folders', 'AppProperties'); OpenLink; ExecuteMacro('[FindFolder(, C:\DOWNLOAD)]', False); CloseLink; Free; end; end;
Вопрос:
Как сделать родительское окно с
фоновым рисунком в клиентской
области?
Ответ:
Для того чтобы сделать это
выполните следующие шаги:
Срздайте новый проект. Установите FormStyle формы в fsMDIForm Разместите Image на форме и загрузите в него картинку. Найдите { Private Declarations } в обьявлении формы и добаьте следующие строки: FClientInstance : TFarProc; FPrevClientProc : TFarProc; procedure ClientWndProc(var Message: TMessage); Добаьте следующие строки в разделе implementation: procedure TMainForm.ClientWndProc(var Message: TMessage); var Dc : hDC; Row : Integer; Col : Integer; begin with Message do case Msg of WM_ERASEBKGND: begin Dc := TWMEraseBkGnd(Message).Dc; for Row := 0 to ClientHeight div Image1.Picture.Height do for Col := 0 to ClientWidth div Image1.Picture.Width do BitBlt(Dc, Col * Image1.Picture.Width, Row * Image1.Picture.Height, Image1.Picture.Width, Image1.Picture.Height, Image1.Picture.Bitmap.Canvas.Handle, 0, 0, SRCCOPY); Result := 1; end; else Result := CallWindowProc(FPrevClientProc, ClientHandle, Msg, wParam, lParam); end; end; В методе формы OnCreate добавьте: FClientInstance := MakeObjectInstance(ClientWndProc); FPrevClientProc := Pointer(GetWindowLong(ClientHandle, GWL_WNDPROC)); SetWindowLong(ClientHandle, GWL_WNDPROC, LongInt(FClientInstance)); Добавьте к проекту новую форму и установите ее свойство FormStyle в fsMDIChild. У Вас получился MDI-проект с "обоями" в клиентской области MDI формы.
Вопрос:
Как глобально перехватить нажатие
кнопки PrintScreen?
Ответ:
В примере для глобального
перехвата нажатия клавиши printscreen
регистрируется горячая клавиша (hot
key).
Пример:
type TForm1 = class(TForm) procedure FormCreate(Sender: TObject); procedure FormDestroy(Sender: TObject); private { Private declarations } procedure WMHotKey(var Msg : TWMHotKey); message WM_HOTKEY; public { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} const id_SnapShot = 101; procedure TForm1.WMHotKey (var Msg : TWMHotKey); begin if Msg.HotKey = id_SnapShot then ShowMessage('GotIt'); end; procedure TForm1.FormCreate(Sender: TObject); begin RegisterHotKey(Form1.Handle, id_SnapShot, 0, VK_SNAPSHOT); end; procedure TForm1.FormDestroy(Sender: TObject); begin UnRegisterHotKey (Form1.Handle, id_SnapShot); end;
Вопрос:
Существует ли способ для
определение числа заданий spoolerа
печати?
Ответ:
Spoolerа печати Windows посылает WM_SPOOLERSTATUS
каждый раз при добавлении и
удалении заданий в очереди печати.
В следующем примере показано как
перехватить это сообщение
Пример:
type TForm1 = class(TForm) Label1: TLabel; private { Private declarations } procedure WM_SpoolerStatus(var Msg : TWMSPOOLERSTATUS); message WM_SPOOLERSTATUS; public { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.WM_SpoolerStatus(var Msg : TWMSPOOLERSTATUS); begin Lable1.Caption := IntToStr(msg.JobsLeft) + ' Jobs currenly in spooler'; msg.Result := 0; end;
Вопрос:
Как определить имена установленых
Com-портов?
Ответ:
Из реестра. См. пример.
Пример:
uses Registry; procedure TForm1.Button1Click(Sender: TObject); var reg : TRegistry; ts : TStrings; i : integer; begin reg := TRegistry.Create; reg.RootKey := HKEY_LOCAL_MACHINE; reg.OpenKey('hardware\devicemap\serialcomm', false); ts := TStringList.Create; reg.GetValueNames(ts); for i := 0 to ts.Count -1 do begin Memo1.Lines.Add(reg.ReadString(ts.Strings[i])); end; ts.Free; reg.CloseKey; reg.free; end;
Вопрос:
Извлечение пиктограммы из exe, dll или
ico-файла
Ответ:
Функция SHELLAPI ExtractIconEx:
Обратите внимание - в примере
функции обьявленны иначе, чем в
модуле ShellAPI
type ThIconArray = array[0..0] of hIcon; type PhIconArray = ^ThIconArray; function ExtractIconExA(lpszFile: PAnsiChar; nIconIndex: Integer; phiconLarge : PhIconArray; phiconSmall: PhIconArray; nIcons: UINT): UINT; stdcall; external 'shell32.dll' name 'ExtractIconExA'; function ExtractIconExW(lpszFile: PWideChar; nIconIndex: Integer; phiconLarge: PhIconArray; phiconSmall: PhIconArray; nIcons: UINT): UINT; stdcall; external 'shell32.dll' name 'ExtractIconExW'; function ExtractIconEx(lpszFile: PAnsiChar; nIconIndex: Integer; phiconLarge : PhIconArray; phiconSmall: PhIconArray; nIcons: UINT): UINT; stdcall; external 'shell32.dll' name 'ExtractIconExA'; procedure TForm1.Button1Click(Sender: TObject); var NumIcons : integer; pTheLargeIcons : phIconArray; pTheSmallIcons : phIconArray; LargeIconWidth : integer; SmallIconWidth : integer; SmallIconHeight : integer; i : integer; TheIcon : TIcon; TheBitmap : TBitmap; begin NumIcons := ExtractIconEx('C:\Program Files\Borland\Delphi 3\BIN\delphi32.exe', -1, nil, nil, 0); if NumIcons 0 then begin LargeIconWidth := GetSystemMetrics(SM_CXICON); SmallIconWidth := GetSystemMetrics(SM_CXSMICON); SmallIconHeight := GetSystemMetrics(SM_CYSMICON); GetMem(pTheLargeIcons, NumIcons * sizeof(hIcon)); GetMem(pTheSmallIcons, NumIcons * sizeof(hIcon)); FillChar(pTheLargeIcons^, NumIcons * sizeof(hIcon), #0); FillChar(pTheSmallIcons^, NumIcons * sizeof(hIcon), #0); ExtractIconEx('C:\Program Files\Borland\Delphi 3\BIN\delphi32.exe', 0, pTheLargeIcons, pTheSmallIcons, numIcons); {$IFOPT R+} {$DEFINE CKRANGE} {$R-} {$ENDIF} for i := 0 to (NumIcons - 1) do begin DrawIcon(Form1.Canvas.Handle, i * LargeIconWidth, 0, pTheLargeIcons^[i]); TheIcon := TIcon. Create; TheBitmap := TBitmap.Create; TheIcon.Handle := pTheSmallIcons^[i]; TheBitmap.Width := TheIcon.Width; TheBitmap.Height := TheIcon.Height; TheBitmap.Canvas.Draw(0, 0, TheIcon); TheIcon.Free; Form1.Canvas.StretchDraw(Rect(i * SmallIconWidth, 100, (i + 1) * SmallIconWidth, 100 + SmallIconHeight), TheBitmap); TheBitmap.Free; end; {$IFDEF CKRANGE} {$UNDEF CKRANGE} {$R+} {$ENDIF} FreeMem(pTheLargeIcons, NumIcons * sizeof(hIcon)); FreeMem(pTheSmallIcons, NumIcons * sizeof(hIcon)); end; end; end.
Вопрос:
как заставить Рабочий Стола Windows
обновится?
Ответ:
См. пример.
Пример:
procedure TForm1.Button1Click(Sender: TObject); begin SendMessage(FindWindow('Progman', 'Program Manager'), WM_COMMAND, $A065, 0); end;
Вопрос:
Перерисовка canvasf моей формы
занимает довольно много времени.
Как определить установлен ли у
пользователя режим перерисовки
всего окна при перемещении чтобы
временно отключить перерисовку
моего окна?
Ответ:
В приведенном примере определяется
включен ли режим "Full Window Drag"
(перерисовки всего окна при
перемещении)
Пример:
procedure TForm1.Button1Click(Sender: TObject); var b : bool; begin SystemParametersInfo(SPI_GETDRAGFULLWINDOWS, 0, @b, 0); if not b then ShowMessage('Full Window Drag is not enabled') else ShowMessage('Full Window Drag is enabled'); end;
Вопрос:
Как уступить выделенный моей
программе квант процессорного
времени другим приложениям?
Ответ:
Вызовите функцию Windows API Sleep()
передав ноль в качестве параметра.
Наверх к содержанию
Вопрос:
Как запускать мою программу на
каждом старте Windows?
Ответ:
Пример
работает и для Win32и для Win16.
uses Registry, {For Win32} IniFiles; {For Win16} {$IFNDEF WIN32} const MAX_PATH = 144; {$ENDIF} {For Win32} procedure TForm1.Button1Click(Sender: TObject); var reg: TRegistry; begin reg := TRegistry.Create; reg.RootKey := HKEY_LOCAL_MACHINE; reg.LazyWrite := false; reg.OpenKey('Software\Microsoft\Windows\CurrentVersion\Run', false); reg.WriteString('My App', Application.ExeName); reg.CloseKey; reg.free; end; {For Win16} procedure TForm1.Button2Click(Sender: TObject); var WinIni : TIniFile; WinIniFileName : array[0..MAX_PATH] of char; s : string; begin GetWindowsDirectory(WinIniFileName, sizeof(WinIniFileName)); StrCat(WinIniFileName, '\win.ini'); WinIni := TIniFile.Create(WinIniFileName); s := WinIni.ReadString('windows', 'run', ''); if s = '' then s := Application.ExeName else s := s + ';' + Application.ExeName; WinIni.WriteString('windows', 'run', s); WinIni.Free; end;
Вопрос:
Как увеличить процессорное время,
выделяемого программе?
Ответ:
Следующий пример изменяет
приоритет приложения. Изменение
приоритета следует использовать с
осторожностью - т.к. присвоение
слишком высокого приоритета может
привети к медленной работе
остальных программ и системы в
целом. См. Win32 help for SetThreadPriority() function.
Пример:
procedure TForm1.Button1Click(Sender: TObject); var ProcessID : DWORD; ProcessHandle : THandle; ThreadHandle : THandle; begin ProcessID := GetCurrentProcessID; ProcessHandle := OpenProcess(PROCESS_SET_INFORMATION, false, ProcessID); SetPriorityClass(ProcessHandle, REALTIME_PRIORITY_CLASS); ThreadHandle := GetCurrentThread; SetThreadPriority(ThreadHandle, THREAD_PRIORITY_TIME_CRITICAL); end;
Вопрос:
Я хочу определить момент окончания
изменения размера или перемещения
окна. Перехватываю сообщения WM_SIZE и
WM_MOVE но я получаю много таких
сообщений а мне нужно узнать когда
именно пользователь закончил
перенос или изменение размеров
окна. Возможно ли это?
Ответ:
В следующем примере показан
перехват сообщения WM_EXITSIZEMOVE Хотя
сообщение документированно только
для Windows NT оно работает точно так же
и под Windows 95. Обратите внимание что
Вы можите перехватить сообщение
WM_ENTERSIZEMOVEдля определения момента
начала пользователем операции
изменения размера или перемещения
окна.
Пример:
type TForm1 = class(TForm) private { Private declarations } public procedure WMEXITSIZEMOVE(var Message: TMessage); message WM_EXITSIZEMOVE; { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.WMEXITSIZEMOVE(var Message: TMessage); begin Form1.Caption := 'Finished Moving and sizing'; end;
Вопрос:
Как определить время последнего
доступа к файлу?
Ответ:
См пример. Примечание: не все
файловые системы поддерживают
время последнего доступа к файлу.
Пример:
procedure TForm1.Button1Click(Sender: TObject); var SearchRec : TSearchRec; Success : integer; DT : TFileTime; ST : TSystemTime; begin Success := SysUtils.FindFirst('C:\autoexec.bat', faAnyFile, SearchRec); if (Success = 0) and (( SearchRec.FindData.ftLastAccessTime.dwLowDateTime <> 0) or ( SearchRec.FindData.ftLastAccessTime.dwHighDateTime <> 0)) then begin FileTimeToLocalFileTime(SearchRec.FindData.ftLastAccessTime,DT); FileTimeToSystemTime(DT,ST); Memo1.Lines.Clear; Memo1.Lines.Add('AutoExec.Bat was last accessed at:'); Memo1.Lines.Add('Year := ' + IntToStr(st.wYear)); Memo1.Lines.Add('Month := ' + IntToStr(st.wMonth)); Memo1.Lines.Add('DayOfWeek := ' + IntToStr(st.wDayOfWeek)); Memo1.Lines.Add('Day := ' + IntToStr(st.wDay)); Memo1.Lines.Add('Hour := ' + IntToStr(st.wHour)); Memo1.Lines.Add('Minute := ' + IntToStr(st.wMinute)); Memo1.Lines.Add('Second := ' + IntToStr(st.wSecond)); Memo1.Lines.Add('Milliseconds := ' + IntToStr(st.wMilliseconds)); end; SysUtils.FindClose(SearchRec); end;
Вопрос:
Как использовать функцию Shell API
SHBrowseForFolder чтобы позволить
пользователю выбрать каталог?
Ответ:
См. пример
Пример:
uses ShellAPI, ShlObj; procedure TForm1.Button1Click(Sender: TObject); var TitleName : string; lpItemID : PItemIDList; BrowseInfo : TBrowseInfo; DisplayName : array[0..MAX_PATH] of char; TempPath : array[0..MAX_PATH] of char; begin FillChar(BrowseInfo, sizeof(TBrowseInfo), #0); BrowseInfo.hwndOwner := Form1.Handle; BrowseInfo.pszDisplayName := @DisplayName; TitleName := 'Please specify a directory'; BrowseInfo.lpszTitle := PChar(TitleName); BrowseInfo.ulFlags := BIF_RETURNONLYFSDIRS; lpItemID := SHBrowseForFolder(BrowseInfo); if lpItemId <> nil then begin SHGetPathFromIDList(lpItemID, TempPath); ShowMessage(TempPath); GlobalFreePtr(lpItemID); end; end;
Вопрос:
Как получить дескриптора окна Window,
сожержащего DOS программу или
программу консольного режима?
Ответ:
В следуещем примере используется
функция Windows API FindWindow(). Обратите
внимание, что WndClass консольного окна
отличаются для Windows 95 и Window NT и
заголовок окна может содержать
полный путь под Windows NT.
Пример:
procedure TForm1.Button1Click(Sender: TObject); var info : TOSVersionInfo; ClassName : string; Title : string; begin {Проверяем - Win95 или NT.} info.dwOSVersionInfoSize := sizeof(info); GetVersionEx(info); if (info.dwPlatformId = VER_PLATFORM_WIN32_NT) then begin ClassName := 'ConsoleWindowClass'; Title := 'Command Prompt'; end else begin ClassName := 'tty'; Title := 'MS-DOS Prompt'; end; ShowMessage(IntToStr(FindWindow(PChar(ClassName), PChar(Title)))); end;
Вопрос:
Возможно ли определить факта
изменения системного времени
другим приложением?
Ответ:
Следующий прмер перехватывает
событие WM_TIMECHANGE. примечание:
Приложение , изменяющее системное
время должно посылать сообщение
WM_TIMECHANGE всем окнам.
type TForm1 = class(TForm) private { Private declarations } procedure WMTIMECHANGE(var Message: TWMTIMECHANGE); message WM_TIMECHANGE; public { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.WMTIMECHANGE(var Message: TWMTIMECHANGE); begin Form1.Caption := 'Time Changed'; end;
Вопрос:
Как очистить пункт документы меню
кнопки Пуск
Ответ:
Вызовите Windows API функцию SHAddToRecentDocs()
передав nil вместо имени файла в
качестве параметра.
Пример:
uses ShlOBJ; procedure TForm1.Button1Click(Sender: TObject); begin SHAddToRecentDocs(SHARD_PATH, nil); end;
Вопрос:
Как опеределить состояние модема
под Win32?
Ответ:
См. пример
Пример:
procedure TForm1.Button1Click(Sender: TObject); var CommPort : string; hCommFile : THandle; ModemStat : DWord; begin CommPort := 'COM2'; {Open the comm port} hCommFile := CreateFile(PChar(CommPort), GENERIC_READ, 0, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0); if hCommFile = INVALID_HANDLE_VALUE then begin ShowMessage('Unable to open '+ CommPort); exit; end; {Get the Modem Status} if GetCommModemStatus(hCommFile, ModemStat) <> false then begin if ModemStat and MS_CTS_ON <> 0 then ShowMessage('The CTS (clear-to-send) is on.'); if ModemStat and MS_DSR_ON <> 0 then ShowMessage('The DSR (data-set-ready) is on.'); if ModemStat and MS_RING_ON <> 0then ShowMessage('The ring indicator is on.'); if ModemStat and MS_RLSD_ON <> 0 then ShowMessage('The RLSD (receive-line-signal-detect) is on.'); end; {Close the comm port} CloseHandle(hCommFile); end;
Вопрос:
Как добавить пункт к системному
меню приложения?
Пример:
type TForm1 = class(TForm) procedure FormCreate(Sender: TObject); private { Private declarations } procedure WMSysCommand(var Msg: TWMSysCommand); message WM_SYSCOMMAND; public { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} const SC_MyMenuItem = WM_USER + 1; procedure TForm1.FormCreate(Sender: TObject); begin AppendMenu(GetSystemMenu(Handle, FALSE), MF_SEPARATOR, 0, ''); AppendMenu(GetSystemMenu(Handle, FALSE), MF_STRING, SC_MyMenuItem, 'My Menu Item'); end; procedure TForm1.WMSysCommand(var Msg: TWMSysCommand); begin if Msg.CmdType = SC_MyMenuItem then ShowMessage('Got the message') else inherited; end;
Вопрос:
Как создание нестандартную
процедуру разбиения слов при
переносах для TEdit, TMemo или TRichEdit?
Ответ:
В следующем примере создается
процедура разбиения слов при
переносах для TMemo. Заметьте, что
реализованная процедура просто
всегда разрешает перенос. Для
дополнительной информации см.таже
документацию к сообщению
EM_SETWORDBREAKPROC.
var OriginalWordBreakProc : pointer; NewWordBreakProc : pointer; function MyWordBreakProc(LPTSTR : pchar; ichCurrent : integer; cch : integer; code : integer) : integer {$IFDEF WIN32} stdcall; {$ELSE} ; export; {$ENDIF} begin result := 0; end; procedure TForm1.FormCreate(Sender: TObject); begin OriginalWordBreakProc := Pointer( SendMessage(Memo1.Handle, EM_GETWORDBREAKPROC, 0, 0)); {$IFDEF WIN32} NewWordBreakProc := @MyWordBreakProc; {$ELSE} NewWordBreakProc := MakeProcInstance(@MyWordBreakProc, hInstance); {$ENDIF} SendMessage(Memo1.Handle, EM_SETWORDBREAKPROC, 0, longint(NewWordBreakProc)); end; procedure TForm1.FormDestroy(Sender: TObject); begin SendMessage(Memo1.Handle, EM_SETWORDBREAKPROC, 0, longint(@OriginalWordBreakProc)); {$IFNDEF WIN32} FreeProcInstance(NewWordBreakProc); {$ENDIF} end;
Вопрос:
Можно ли скопировать группу файлов,
используя стандартный диалог с
анимацией Копирование Файлов,
который использует
"Проводник" (Explorer)?
Ответ:
В следующем примере используется
функция SHFileOperation для копирования
группы файлов и показа
анимированного диалога. Вы можете
использовать также следующие флаги
для копирования, удаления, переноса
и переименования файлов.
TO_COPY FO_DELETE FO_MOVE FO_RENAME
Примечание:
буфер, содержащий имена файлов для
копирования должен заканчиваться
двумя нулевыми символами.
Пример:
uses ShellAPI; procedure TForm1.Button1Click(Sender: TObject); var Fo : TSHFileOpStruct; buffer : array[0..4096] of char; p : pchar; begin FillChar(Buffer, sizeof(Buffer), #0); p := @buffer; p := StrECopy(p, 'C:\DownLoad\1.ZIP') + 1; p := StrECopy(p, 'C:\DownLoad\2.ZIP') + 1; p := StrECopy(p, 'C:\DownLoad\3.ZIP') + 1; StrECopy(p, 'C:\DownLoad\4.ZIP'); FillChar(Fo, sizeof(Fo), #0); Fo.Wnd := Handle; Fo.wFunc := FO_COPY; Fo.pFrom := @Buffer; Fo.pTo := 'D:\'; Fo.fFlags := 0; if ((SHFileOperation(Fo) <> 0) or (Fo.fAnyOperationsAborted <> false)) then ShowMessage('Cancelled') end;
Вопрос:
Как узнать серийный номер диска
Ответ:
procedure TForm1.Button1Click(Sender: TObject); var VolumeName, FileSystemName : array [0..MAX_PATH-1] of Char; VolumeSerialNo : DWord; MaxComponentLength, FileSystemFlags : Integer; begin GetVolumeInformation('C:\',VolumeName,MAX_PATH,@VolumeSerialNo, MaxComponentLength,FileSystemFlags, FileSystemName,MAX_PATH); Memo1.Lines.Add('VName = '+VolumeName); Memo1.Lines.Add('SerialNo = $'+IntToHex(VolumeSerialNo,8)); Memo1.Lines.Add('CompLen = '+IntToStr(MaxComponentLength)); Memo1.Lines.Add('Flags = $'+IntToHex(FileSystemFlags,4)); Memo1.Lines.Add('FSName = '+FileSystemName); end;
Вопрос:
Как узнать является диск
CD-диском,сетевым диском,
виртуальным диском или сьемным
диском?
Ответ:
Windows API функция GetDriveType().
Пример:
procedure TForm1.Button1Click(Sender: TObject); begin case GetDriveType('C:\') of 0 : ShowMessage('The drive type cannot be determined'); 1 : ShowMessage('The root directory does not exist'); DRIVE_REMOVABLE:ShowMessage('The disk can be removed'); DRIVE_FIXED : ShowMessage('The disk cannot be removed'); DRIVE_REMOTE : ShowMessage('The drive is remote (network) drive'); DRIVE_CDROM : ShowMessage('The drive is a CD-ROM drive'); DRIVE_RAMDISK : ShowMessage('The drive is a RAM disk'); end; end;
Вопрос:
Как проверить готовность диска без
появления окна ошибки Windows?
Ответ:
Вы можете использовать функцию Windows
API SetErrorMode() для отключения диалога
Window's critical Error.
Пример:
function IsDriveReady(DriveLetter : char) : bool; var OldErrorMode : Word; OldDirectory : string; begin OldErrorMode := SetErrorMode(SEM_NOOPENFILEERRORBOX); GetDir(0, OldDirectory); {$I-} ChDir(DriveLetter + ':\'); {$I+} if IoResult <> 0 then Result := False else Result := True; ChDir(OldDirectory); SetErrorMode(OldErrorMode); end; procedure TForm1.Button1Click(Sender: TObject); begin if not IsDriveReady('A') then ShowMessage('Drive Not Ready') else ShowMessage('Drive is Ready'); end;
Вопрос:
Использование FindFirst для поиска
файлов.
Ответ:
begin Result := SysUtils.FindFirst(Path, Attr, SearchRec); while Result = 0 do begin ProcessSearchRec(SearchRec); Result := SysUtils.FindNext(SearchRec); end; SysUtils.FindClose(SearchRec); end;
Вопрос:
Как получить дескриптор окна
другого приложения и сделать его
активным?
Ответ:
Использование фуекции Windows API
FindWindow() - простейший способ
нахождение окна, при условии, что
известен его заголовок или имя
оконного класса. Если Вам известна
только часть заголовка окна
(например 'Netscape - ' + 'какой-то
неизвестный URL'), Вам нужно
использовать функцию EnumWindows() для
получения всех окон, затем вызывать
функцию GetWindowsText() и GetClassName для
поиска нужного окна. Следующий
пример находит первое окно,
содержащее совпадающую часть
заголовка окна и полностью
совпадающее название оконного
класса (если он задан) и делает это
окно активным.
type PFindWindowStruct = ^TFindWindowStruct; TFindWindowStruct = record Caption : string; ClassName : string; WindowHandle : THandle; end; function EnumWindowsProc(hWindow : hWnd; lParam : LongInt) : Bool {$IFDEF Win32} stdcall; {$ELSE} ; export; {$ENDIF} var lpBuffer : PChar; WindowCaptionFound : bool; ClassNameFound : bool; begin GetMem(lpBuffer, 255); Result := True; WindowCaptionFound := False; ClassNameFound := False; try if GetWindowText(hWindow, lpBuffer, 255) 0 then if Pos(PFindWindowStruct(lParam).Caption, StrPas(lpBuffer)) 0 then WindowCaptionFound := true; if PFindWindowStruct(lParam).ClassName = '' then ClassNameFound := True else if GetClassName(hWindow, lpBuffer, 255) 0 then if Pos(PFindWindowStruct(lParam).ClassName, StrPas(lpBuffer)) 0 then ClassNameFound := True; if (WindowCaptionFound and ClassNameFound) then begin PFindWindowStruct(lParam).WindowHandle := hWindow; Result := False; end; finally FreeMem(lpBuffer, sizeof(lpBuffer^)); end; end; function FindAWindow(Caption : string; ClassName : string) : THandle; var WindowInfo : TFindWindowStruct; begin with WindowInfo do begin Caption := Caption; ClassName := ClassName; WindowHandle := 0; EnumWindows(@EnumWindowsProc, LongInt(@WindowInfo)); FindAWindow := WindowHandle; end; end; procedure TForm1.Button1Click(Sender: TObject); var TheWindowHandle : THandle; begin TheWindowHandle := FindAWindow('Netscape - ', ''); if TheWindowHandle = 0 then ShowMessage('Window Not Found!') else BringWindowToTop(TheWindowHandle); end;
Вопрос:
Как написать программу не имеющую
ни одной формы?
Ответ:
Создайте новое приложение, затем
удалите из проекта все unitы - (Delphi 3 -
View - Project Manager)
(Delphi 4 - Project - Remove from project)
Откройте файл проекта
(Delphi 3 - View - Project Source)
(Delphi 3 - Project - View Source)
и отредактируйте его так как
приведино ниже.
Пример:
program Project1; {$R *.RES} uses SysUtils; var f : TextFile; begin AssignFile(f, 'TestFile.Txt'); ReWrite(f); Writeln(f, 'Test'); Close(f); end.
Вопрос:
Почему возникает ошибка при
передаче параметров типа boolean
равного True в некоторые внешней
функции
Ответ:
В Delphi 3 значение "True" для типов
ByteBool, WordBool LongBool представляется как
-1 для совместимости с Microsoft Visual Basic.
Многие компиляторы представляют
"True" как либо "не нуль"
либо 1. При передаче параметров в не
Visual Basic-приложения Вам следует
придерживаться следующей техники
во избежание несовместимости:
LongBool(Abs(True));
При приеме значений типа boolean из внешних программ Вам следует всегда проверять его на значение "False". Эта техника всегда работает, поскольку "False" всегда представляется нулем.
if BoolValPassed <> False then DoSomething.
Вопрос:
Как получить длинное имя файла или
каталога, зная короткое имя?
Ответ:
Используйте Win32_Find_Data поле TSearchRec.
Пример:
procedure TForm1.Button1Click(Sender: TObject); var SearchRec : TSearchRec; Success : integer; begin Success := SysUtils.FindFirst('C:\DownLoad\dial-u~1.htm', faAnyFile, SearchRec); if Success = 0 then begin ShowMessage(SearchRec.FindData.CFileName); end; SysUtils.FindClose(SearchRec); end;
Вопрос:
Как временно отключить range checking для
участка программы, а затем вновь
вклчить его?
Ответ:
Можно сделать это, используя
"IFOPT" и "DEFINE".
type PSomeArray = ^TSomeArray; TSomeArray = array[0..0] of integer; procedure TForm1.Button1Click(Sender: TObject); var p : PSomeArray; i : integer; begin {$IFOPT R+} {$DEFINE CKRANGE} {$R-} {$ENDIF} GetMem(p, sizeof(integer) * 200); try for i := 1 to 200 do p[i] := i; finally FreeMem(p, sizeof(integer) * 200); end; {$IFDEF CKRANGE} {$UNDEF CKRANGE} {$R+} {$ENDIF} end;
Вопрос:
Как получить имя файла и путь
локальной таблицы?
Ответ:
Следующий пример взят из файла
BDE32.HLP Borland/CommonFiles/BDE directory:
implementation {$R *.DFM} uses DbiTypes, DbiProcs; function fDbiFormFullName(Tbl: TTable): String; var Props: CurProps; Buffer1 : array[0..DBIMAXPATHLEN] of char; Buffer2 : array[0..DBIMAXPATHLEN] of char; begin Check(DbiGetCursorProps(Tbl.Handle,Props)); StrPCopy(Buffer1, Tbl.TableName); Check(DbiFormFullName(Tbl.DBHandle, @Buffer1, Props.szTableType, @Buffer2)); Result := StrPas(Buffer2); end; procedure TForm1.Button1Click(Sender: TObject); begin Memo1.Lines.Add(fDbiFormFullName(Table1)); end; Примечание: Таблица должна быть открытой. Работает с локальными таблицами.
Вопрос:
Как получить дескриптор панели
задач (TaskBar)?
Ответ:
hTaskbar := FindWindow('Shell_TrayWnd', Nil ); Наверх
к содержанию
Вопрос:
Как из программы запустить Screen Saver?
Ответ:
Представленная ниже функция
демонстрирует как это сделать
function TurnScreenSaverOn : bool; var b : bool; begin result := false; if SystemParametersInfo(SPI_GETSCREENSAVEACTIVE, 0, @b, 0) <> true then exit; if not b then exit; PostMessage(GetDesktopWindow, WM_SYSCOMMAND, SC_SCREENSAVE, 0); result := true; end;
Вопрос:
Как выяснить установлены ли в
системе шрифты TrueType?
Ответ:
function IsTrueTypeAvailable : bool; var {$IFDEF WIN32} rs : TRasterizerStatus; {$ELSE} rs : TRasterizer_Status; {$ENDIF} begin result := false; if not GetRasterizerCaps(rs, sizeof(rs)) then exit; if rs.WFlags and TT_AVAILABLE <> TT_AVAILABLE then exit; if rs.WFlags and TT_ENABLED <> TT_ENABLED then exit; result := true; end;
Вопрос:
Как переслать файл в Мусорную
Корзину?
Ответ:
Используйте функцию SHFileOperation().
uses ShellAPI; procedure SendToRecycleBin(FileName: string); var SHF: TSHFileOpStruct; begin with SHF do begin Wnd := Application.Handle; wFunc := FO_DELETE; pFrom := PChar(FileName); fFlags := FOF_SILENT or FOF_ALLOWUNDO; end; SHFileOperation(SHF); end; procedure TForm1.Button1Click(Sender: TObject); begin SendToRecycleBin('c:\DownLoad\Test.gif'); end;
Вопрос:
Как изменить обои Windows програмно?
Ответ:
Изменить обои можно функцией
SystemParametersInfo()Б переслав ей в
качестве параметров константу
SPI_SETDESKWALLPAPER и имя нового файла
обоев.
Пример:
SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, PChar('C:\SOMEPATH\SOME.BMP'), SPIF_SENDWININICHANGE);
Вопрос:
Как выяснить запущен ли Delphi / C++ Builder?
Ответ:
Используйте функцию FindWindow. (Класс
главного окна Delphi / C++ Builder - TAppBuilder)
if FindWindow('TAppBuilder', Nil) <> 0 Then ShowMessage('Delphi and or C++ Builder is running');
Вопрос:
Как програмно выяснить версию Windows?
Ответ:
{$IFDEF WIN32} function GetVersionEx(lpOs : pointer) : BOOL; stdcall; external 'kernel32' name 'GetVersionExA'; {$ENDIF} procedure GetWindowsVersion(var Major : integer; var Minor : integer); var {$IFDEF WIN32} lpOS, lpOS2 : POsVersionInfo; {$ELSE} l : longint; {$ENDIF} begin {$IFDEF WIN32} GetMem(lpOS, SizeOf(TOsVersionInfo)); lpOs^.dwOSVersionInfoSize := SizeOf(TOsVersionInfo); while getVersionEx(lpOS) = false do begin GetMem(lpos2, lpos^.dwOSVersionInfoSize + 1); lpOs2^.dwOSVersionInfoSize := lpOs^.dwOSVersionInfoSize + 1; FreeMem(lpOs, lpOs^.dwOSVersionInfoSize); lpOS := lpOs2; end; Major := lpOs^.dwMajorVersion; Minor := lpOs^.dwMinorVersion; FreeMem(lpOs, lpOs^.dwOSVersionInfoSize); {$ELSE} l := GetVersion; Major := LoByte(LoWord(l)); Minor := HiByte(LoWord(l)); {$ENDIF} end; procedure TForm1.Button1Click(Sender: TObject); var Major : integer; Minor : integer; begin GetWindowsVersion(Major, Minor); Memo1.Lines.Add(IntToStr(Major)); Memo1.Lines.Add(IntToStr(Minor)); end;
Вопрос:
Как узнать переменные окружения
(environment variable) DOS, например path?
Ответ:
Windows API - функция GetDOSEnvironment() для Win16 и GetEnvironmentStrings() для Win32.
Пример:
procedure TForm1.Button1Click(Sender: TObject); var p : pChar; begin Memo1.Lines.Clear; Memo1.WordWrap := false; {$IFDEF WIN32} p := GetEnvironmentStrings; {$ELSE} p := GetDOSEnvironment; {$ENDIF} while p^ <> #0 do begin Memo1.Lines.Add(StrPas(p)); inc(p, lStrLen(p) + 1); end; {$IFDEF WIN32} FreeEnvironmentStrings(p); {$ENDIF} end;
Вопрос:
Как рисовать непосредственно на
Рабочем столе?
Ответ:
Пример:
procedure TForm1.Button1Click(Sender: TObject); var dc : hdc; begin dc := GetDc(0); MoveToEx(Dc, 0, 0, nil); LineTo(Dc, 300, 300); ReleaseDc(0, Dc); end;
Вопрос:
Как определить каталог Windows?
Ответ:
Вызовите функцию GetWindowsDirectory(). Если
Вас интересует каталог System,
вызовите функцию GetSystemDirectory().
Пример:
{$IFNDEF WIN32} const MAX_PATH = 144; {$ENDIF} procedure TForm1.Button1Click(Sender: TObject); var a : Array[0..MAX_PATH] of char; begin GetWindowsDirectory(a, sizeof(a)); ShowMessage(StrPas(a)); GetSystemDirectory(a, sizeof(a)); ShowMessage(StrPas(a)); end;
Вопрос:
Как определить размер рабочего
стола без Тaskbar'а?
Ответ:
Воспользуйтесь функцией
SystemParametersInfo(), переслав ей в качестве
параметров - SPI_GETWORKAREA и адрес
структуры типа TRect, куда будут
передан полученный результат.
Пример:
procedure TForm1.Button1Click(Sender: TObject); var r : TRect; begin SystemParametersInfo(SPI_GETWORKAREA, 0, @r, 0); Memo1.Lines.Add(IntToStr(r.Top)); Memo1.Lines.Add(IntToStr(r.Left)); Memo1.Lines.Add(IntToStr(r.Bottom)); Memo1.Lines.Add(IntToStr(r.Right)); end;
Вопрос:
Как закрыть CD програмно?
Ответ:
Вызовите функцию mciSendCommand (из
библиотекиMMSystem) передав ей
параметр MCI_SET_DOOR_CLOSED.
Пример:
uses MMSystem; procedure CloseCD(Drive : char); var mp : TMediaPlayer; begin result := false; Application.ProcessMessages; mp := TMediaPlayer.Create(nil); mp.Visible := false; mp.Parent := Application.MainForm; mp.Shareable := true; mp.DeviceType := dtCDAudio; mp.FileName := Drive + ':'; mp.Open; Application.ProcessMessages; mciSendCommand(mp.DeviceID, MCI_SET, MCI_SET_DOOR_CLOSED, 0); Application.ProcessMessages; mp.Close; Application.ProcessMessages; mp.free; result := true; end; procedure TForm1.Button1Click(Sender: TObject); begin CloseCD('D'); end;
Вопрос:
Как определить свободное дисковое
пространство на дисках размером
больше 2 ГБ?
Ответ:
Вызовите функцию GetDiskFreeSpaceEx().
Возвращаемый функцией результат
типа integers конвертируйте в doubles.
Пример:
function GetDiskFreeSpaceEx(lpDirectoryName: PAnsiChar; var lpFreeBytesAvailableToCaller : Integer; var lpTotalNumberOfBytes: Integer; var lpTotalNumberOfFreeBytes: Integer) : bool; stdcall; external kernel32 name 'GetDiskFreeSpaceExA'; procedure GetDiskSizeAvail(TheDrive : PChar; var TotalBytes : double; var TotalFree : double); var AvailToCall : integer; TheSize : integer; FreeAvail : integer; begin GetDiskFreeSpaceEx(TheDrive, AvailToCall, TheSize, FreeAvail); {$IFOPT Q+} {$DEFINE TURNOVERFLOWON} {$Q-} {$ENDIF} if TheSize = 0 then TotalBytes := TheSize else if TheSize = -1 then begin TotalBytes := $7FFFFFFF; TotalBytes := TotalBytes * 2; TotalBytes := TotalBytes + 1; end else begin TotalBytes := $7FFFFFFF; TotalBytes := TotalBytes + abs($7FFFFFFF - TheSize); end; if AvailToCall = 0 then TotalFree := AvailToCall else if AvailToCall = -1 then begin TotalFree := $7FFFFFFF; TotalFree := TotalFree * 2; TotalFree := TotalFree + 1; end else begin TotalFree := $7FFFFFFF; TotalFree := TotalFree + abs($7FFFFFFF - AvailToCall); end; end; procedure TForm1.Button1Click(Sender: TObject); var TotalBytes : double; TotalFree : double; begin GetDiskSizeAvail('C:\', TotalBytes, TotalFree); ShowMessage(FloatToStr(TotalBytes)); ShowMessage(FloatToStr(TotalFree)); end;
Вопрос:
Как спрятать Панель Задач Windows (Task
Bar)?
Ответ:
Вначале необходимо вызвать функцию
FindWindow(), чтобы определить handle TaskBar.
Затем вызвите функцию ShowWindow(),
передав ей в качестве параметра
костанту SW_HIDE.
Пример:
procedure TForm1.Button1Click(Sender: TObject); var hTaskBar : THandle; begin hTaskbar := FindWindow('Shell_TrayWnd', Nil); ShowWindow(hTaskBar, SW_HIDE); end; procedure TForm1.Button2Click(Sender: TObject); var hTaskBar : THandle; begin hTaskbar := FindWindow('Shell_TrayWnd', Nil); ShowWindow(hTaskBar, SW_SHOWNORMAL); end;
Вопрос:
Как определить подключен ли
компюетер к сети.
Ответ:
Воспользуйтесь функцией GetSystemMetrics(),
переслав ей флаг SM_NETWORK.
Пример:
procedure TForm1.Button1Click(Sender: TObject); begin if GetSystemMetrics(SM_NETWORK) AND $01 = $01 then ShowMessage('Machine is attached to network') else ShowMessage('Machine is not attached to network'); end;
Вопрос:
Как добавить документ в меню ПУСК -
ДОКУМЕНТЫ?
Ответ:
Используйте функцию SHAddToRecentDocs.
Пример:
uses ShlOBJ; procedure TForm1.Button1Click(Sender: TObject); var s : string; begin s := 'C:\DownLoad\ntkfaq.html'; SHAddToRecentDocs(SHARD_PATH, pChar(s)); end;
Вопрос:
Как программно изменить текущий
порт принтера?
Ответ:
Используйте метод SetPrinter класса
TPrinter.
Пример:
uses Printers; {$IFNDEF WIN32} const MAX_PATH = 144; {$ENDIF} procedure TForm1.Button1Click(Sender: TObject); var pDevice : pChar; pDriver : pChar; pPort : pChar; hDMode : THandle; PDMode : PDEVMODE; begin if PrintDialog1.Execute then begin GetMem(pDevice, cchDeviceName); GetMem(pDriver, MAX_PATH); GetMem(pPort, MAX_PATH); Printer.GetPrinter(pDevice, pDriver, pPort, hDMode); Printer.SetPrinter(pDevice, PDriver, 'FILE:', hDMode); FreeMem(pDevice, cchDeviceName); FreeMem(pDriver, MAX_PATH); FreeMem(pPort, MAX_PATH); Printer.BeginDoc; Printer.Canvas.TextOut(100, 100, 'Delphi Is RAD!'); Printer.EndDoc; end; end;
Вопрос:
Как корректно определить изменения
в оборудовании PlugNPlay?
Ответ:
Пример:
type TForm1 = class(TForm) Button1: TButton; private { Private declarations } procedure WMDeviceChange(var Message: TMessage); message WM_DEVICECHANGE; public { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} const DBT_DEVICEARRIVAL = $8000; const DBT_DEVICEQUERYREMOVE = $8001; const DBT_DEVICEQUERYREMOVEFAILED = $8002; const DBT_DEVICEREMOVEPENDING = $8003; const DBT_DEVICEREMOVECOMPLETE = $8004; const DBT_DEVICETYPESPECIFIC = $8005; const DBT_CONFIGCHANGED = $0018; procedure TForm1.WMDeviceChange(var Message: TMessage); var s : string; begin {Do Something here} case Message.wParam of DBT_DEVICEARRIVAL : s := 'A device has been inserted and is now available'; DBT_DEVICEQUERYREMOVE: begin s := 'Permission to remove a device is requested'; ShowMessage(s); {True grants premission} Message.Result := integer(true); exit; end; DBT_DEVICEQUERYREMOVEFAILED : s := 'Request to remove a device has been canceled'; DBT_DEVICEREMOVEPENDING : s := 'Device is about to be removed'; DBT_DEVICEREMOVECOMPLETE : s := 'Device has been removed'; DBT_DEVICETYPESPECIFIC : s := 'Device-specific event'; DBT_CONFIGCHANGED : s:= 'Current configuration has changed' else s := 'Unknown Device Message'; end; ShowMessage(s); inherited; end;
Вопрос:
Как после записи в ini-файл сбросить
cache на диск, чтоб задействовать
изменения?
Ответ:
Вызовите функцию WriteProfileString() или
WritePrivateProfileString(), передав ей в
качестве параметров секции, ключа и
строки - nil.
Пример:
WriteProfileString(nil, nil, nil); WritePrivateProfileString(nil, nil, nil, FileName);
Вопрос:
Как с помощью Проводника открыть
конкретный каталог?
Ответ:
Пример:
uses ShellApi; procedure TForm1.Button1Click(Sender: TObject); begin ShellExecute(0, 'explore', 'C:\WINDOWS', nil, nil, SW_SHOWNORMAL); end;
Вопрос:
Как запустить аплет Панели
управления?
Ответ:
Запустить аплет Панели управления
можно вызвав функцию WinExec, для
выполнения файла control.exe, которому
передано имя аплета. Обычно аплеты
панели управления расположены в
каталоге System Windows и имеют
расширение .cpl.
Пример:
procedure TForm1.Button1Click(Sender: TObject); begin WinExec('C:\WINDOWS\CONTROL.EXE TIMEDATE.CPL', sw_ShowNormal); WinExec('C:\WINDOWS\CONTROL.EXE MOUSE', sw_ShowNormal); WinExec('C:\WINDOWS\CONTROL.EXE PRINTERS', sw_ShowNormal); end;
Вопрос:
Как печатать в цвете?
Ответ:
Обычно нет необходимости
переводить принтер в режим цветной
печати, если он установлен в этот
режим. Windows автоматически переведет
цветную печать в черно-белую, если
принтер не поддерживает цветной
печати. Если Вам необходимо
програмно изменить режим цвета, Вы
можете обратится к структуре DevMode
драйвера принтера.
Пример:
uses Printers; procedure TForm1.Button1Click(Sender: TObject); var Device : array[0..255] of char; Driver : array[0..255] of char; Port : array[0..255] of char; hDMode : THandle; PDMode : PDEVMODE; begin with Printer do begin PrinterIndex := PrinterIndex; GetPrinter(Device, Driver, Port, hDMode); if hDMode <> 0 then begin pDMode := GlobalLock(hDMode); if pDMode <> nil then begin pDMode.dmFields := pDMode.dmFields or dm_Color; pDMode.dmColor := DMCOLOR_COLOR; GlobalUnlock(hDMode); end; end; PrinterIndex := PrinterIndex; BeginDoc; Canvas.Font.Color := clRed; Canvas.TextOut(100,100, 'Red As A Rose!'); EndDoc; end; end;
Вопрос:
Как открыть URL браузером,
установленным по умолчанию?
Ответ:
Используйте функцию ShellExecute.
Пример:
uses ShellAPI; procedure TForm1.Button1Click(Sender: TObject); begin ShellExecute(Form1.Handle, nil, 'http://www.borland.com', nil, nil, SW_SHOWNORMAL); end;
Вопрос:
Как стереть ехе-файл во время его
исполнения?
Ответ:
Это не возможно. Вы можете стереть
его во время следующего запуска
Windows, добавив ключ RunOnce:
HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\RunOnce
Пример:
uses Registry; procedure TForm1.Button1Click(Sender: TObject); var reg: TRegistry; begin reg := TRegistry.Create; with reg do begin RootKey := HKEY_LOCAL_MACHINE; LazyWrite := false; OpenKey('Software\Microsoft\Windows\CurrentVersion\RunOnce', false); WriteString('Delete Me!','command.com /c del FILENAME.EXT'); CloseKey; free; end; end;
Вопрос:
Как програмноинсталировать шрифты
TrueType?
Ответ:
Скопируйте файл шрифта в
директорию Windows\Fonts, и добавьте
строку с именем шрифта и его
расположением в разделе
"'Software\Microsoft\Windows\CurrentVersion\Fonts".
Вызовите функцию AddFontRecource(), а затем
передайте системе сообщение
WM_FONTCHANGE. И наконец, для удоления
установленного шрифта, вызовите
функцию RemoveFontRecource(), а затем
передайте системе сообщение
WM_FONTCHANGE.
Пример:
uses Registry; procedure TForm1.Button1Click(Sender: TObject); var reg: TRegistry; b : bool; begin CopyFile('C:\DOWNLOAD\FP000100.TTF', 'C:\WINDOWS\FONTS\FP000100.TTF', b); reg := TRegistry.Create; reg.RootKey := HKEY_LOCAL_MACHINE; reg.LazyWrite := false; reg.OpenKey('Software\Microsoft\Windows\CurrentVersion\Fonts', false); reg.WriteString('TESTMICR (TrueType)','FP000100.TTF'); reg.CloseKey; reg.free; {Add the font resource} AddFontResource('c:\windows\fonts\FP000100.TTF'); SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0); {Remove the resource lock} RemoveFontResource('c:\windows\fonts\FP000100.TTF'); SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0); end;
Вопрос:
Как получить список часовых поясов?
Ответ:
Пример:
uses Registry; procedure TForm1.Button1Click(Sender: TObject); var reg : TRegistry; ts : TStrings; i : integer; begin reg := TRegistry.Create; reg.RootKey := HKEY_LOCAL_MACHINE; reg.OpenKey( 'SOFTWARE\Microsoft\Windows\CurrentVersion\Time Zones', false); if reg.HasSubKeys then begin ts := TStringList.Create; reg.GetKeyNames(ts); reg.CloseKey; for i := 0 to ts.Count -1 do begin reg.OpenKey( 'SOFTWARE\Microsoft\Windows\CurrentVersion\Time Zones\' + ts.Strings[i], false); Memo1.Lines.Add(ts.Strings[i]); Memo1.Lines.Add(reg.ReadString('Display')); Memo1.Lines.Add(reg.ReadString('Std')); Memo1.Lines.Add(reg.ReadString('Dlt')); Memo1.Lines.Add('----------------------'); reg.CloseKey; end; ts.Free; end else reg.CloseKey; reg.free; end;
Вопрос:
Какие значения возвращает функция
GetTimeZoneInformation()?
Ответ:
const TIME_ZONE_ID_UNKNOWN = 0; const TIME_ZONE_ID_STANDARD = 1; const TIME_ZONE_ID_DAYLIGHT = 2;
Вопрос:
Как сделать прозрачным фон текста?
Ответ:
Используйте функцию SetBkMode().
Пример:
procedure TForm1.Button1Click(Sender: TObject); var OldBkMode : integer; begin with Form1.Canvas do begin Brush.Color := clRed; FillRect(Rect(0, 0, 100, 100)); Brush.Color := clBlue; TextOut(10, 20, 'Not Transparent!'); OldBkMode := SetBkMode(Handle, TRANSPARENT); TextOut(10, 50, 'Transparent!'); SetBkMode(Handle, OldBkMode); end; end;
Вопрос:
Как получить информацию о версии
файла?
Ответ:
Для этого необходимо вызвать
несколько функций API. В
приведеннном ниже примере
проверяется версия shell32.dll. Функция
возвращает значение True - если
версия DLL больше или равна 4.71
function TForm1.CheckShell32Version: Boolean; procedure GetFileVersion(FileName: string; var Major1, Major2, Minor1, Minor2: Integer); { Helper function to get the actual file version information } var Info: Pointer; InfoSize: DWORD; FileInfo: PVSFixedFileInfo; FileInfoSize: DWORD; Tmp: DWORD; begin // Get the size of the FileVersionInformatioin InfoSize := GetFileVersionInfoSize(PChar(FileName), Tmp); // If InfoSize = 0, then the file may not exist, or // it may not have file version information in it. if InfoSize = 0 then raise Exception.Create('Can''t get file version information for ' + FileName); // Allocate memory for the file version information GetMem(Info, InfoSize); try // Get the information GetFileVersionInfo(PChar(FileName), 0, InfoSize, Info); // Query the information for the version VerQueryValue(Info, '\', Pointer(FileInfo), FileInfoSize); // Now fill in the version information Major1 := FileInfo.dwFileVersionMS shr 16; Major2 := FileInfo.dwFileVersionMS and $FFFF; Minor1 := FileInfo.dwFileVersionLS shr 16; Minor2 := FileInfo.dwFileVersionLS and $FFFF; finally FreeMem(Info, FileInfoSize); end; end; var tmpBuffer: PChar; Shell32Path: string; VersionMajor: Integer; VersionMinor: Integer; Blank: Integer; begin tmpBuffer := AllocMem(MAX_PATH); // Get the shell32.dll path try GetSystemDirectory(tmpBuffer, MAX_PATH); Shell32Path := tmpBuffer + '\shell32.dll'; finally FreeMem(tmpBuffer); end; // Check to see if it exists if FileExists(Shell32Path) then begin // Get the file version GetFileVersion(Shell32Path, VersionMajor, VersionMinor, Blank, Blank); // Do something, such as require a certain version // (such as greater than 4.71) if (VersionMajor = 4) and (VersionMinor = 71) then Result := True else Result := False; end else Result := False; end;
Вопрос:
Как создать иконку из bitmap'а?
Ответ:
Нужно создать два bitmap'а: bitmap-маску
("AND" bitmap) и bitmap-картинку (XOR bitmap).
Потом передать дескрипторы
"AND" и "XOR" bitmap-ов API функции
CreateIconIndirect()
Пример:
procedure TForm1.Button1Click(Sender: TObject); var IconSizeX : integer; IconSizeY : integer; AndMask : TBitmap; XOrMask : TBitmap; IconInfo : TIconInfo; Icon : TIcon; begin {Get the icon size} IconSizeX := GetSystemMetrics(SM_CXICON); IconSizeY := GetSystemMetrics(SM_CYICON); {Create the "And" mask} AndMask := TBitmap.Create; AndMask.Monochrome := true; AndMask.Width := IconSizeX; AndMask.Height := IconSizeY; {Draw on the "And" mask} AndMask.Canvas.Brush.Color := clWhite; AndMask.Canvas.FillRect(Rect(0, 0, IconSizeX, IconSizeY)); AndMask.Canvas.Brush.Color := clBlack; AndMask.Canvas.Ellipse(4, 4, IconSizeX - 4, IconSizeY - 4); {Draw as a test} Form1.Canvas.Draw(IconSizeX * 2, IconSizeY, AndMask); {Create the "XOr" mask} XOrMask := TBitmap.Create; XOrMask.Width := IconSizeX; XOrMask.Height := IconSizeY; {Draw on the "XOr" mask} XOrMask.Canvas.Brush.Color := ClBlack; XOrMask.Canvas.FillRect(Rect(0, 0, IconSizeX, IconSizeY)); XOrMask.Canvas.Pen.Color := clRed; XOrMask.Canvas.Brush.Color := clRed; XOrMask.Canvas.Ellipse(4, 4, IconSizeX - 4, IconSizeY - 4); {Draw as a test} Form1.Canvas.Draw(IconSizeX * 4, IconSizeY, XOrMask); {Create a icon} Icon := TIcon.Create; IconInfo.fIcon := true; IconInfo.xHotspot := 0; IconInfo.yHotspot := 0; IconInfo.hbmMask := AndMask.Handle; IconInfo.hbmColor := XOrMask.Handle; Icon.Handle := CreateIconIndirect(IconInfo); {Destroy the temporary bitmaps} AndMask.Free; XOrMask.Free; {Draw as a test} Form1.Canvas.Draw(IconSizeX * 6, IconSizeY, Icon); {Assign the application icon} Application.Icon := Icon; {Force a repaint} InvalidateRect(Application.Handle, nil, true); {Free the icon} Icon.Free; end;
Вопрос:
Как преобразовать RGB-цвет в оттенки
серого?
Ответ:
В приведенном примере для
преобразования RGB-цвета
используются коэффициенты,
принятые в телевидении:
function RgbToGray(RGBColor : TColor) : TColor; var Gray : byte; begin Gray := Round((0.30 * GetRValue(RGBColor)) + (0.59 * GetGValue(RGBColor)) + (0.11 * GetBValue(RGBColor ))); Result := RGB(Gray, Gray, Gray); end; procedure TForm1.FormCreate(Sender: TObject); begin Shape1.Brush.Color := RGB(255, 64, 64); Shape2.Brush.Color := RgbToGray(Shape1.Brush.Color); end;
Вопрос:
Как держать приложение в
минимизированном виде?
Ответ:
Установите свойство WindowState в Minimized.
Создайте обработчик сообщения
WM_QueryOpen.
Пример:
{Place this code in the private section of the Form declaration} procedure WMQueryOpen(VAR Msg : TWMQueryOpen); message WM_QUERYOPEN; {Place this code in the Form implementation section} procedure TForm1.WMQueryOpen(VAR Msg : TWMQueryOpen); begin Msg.Result := 0; end;
Вопрос:
при вызове функции RegisterClass я
получаю ошибку:
"Incompatible types: 'TPersistantClass' and
'TWndClassA'"
Ответ:
Функция RegisterClass() обьявлена в
модулях Classes и Windows unit. Чтобы вызвать
функцию из модуля Windows просто
добавте префикс "Windows."
Пример:
procedure TForm1.Button1Click(Sender: TObject); wc : TWndClass; begin Windows.RegisterClass(wc) end;
Вопрос:
Как принять файлы, брошенные на мою
форму по drag & drop
Ответ:
Нужно сообщить Windows, что ваша форма
принимает файлы по drag & drop с
помощью функции Shell API DragAcceptFiles.(в
обработчике события form create) Затем
нужно реагироавть на сообытия 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; { Private declarations } public { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} uses ShellApi; procedure TForm1.FormCreate(Sender: TObject); begin {Let Windows know we accept dropped files} DragAcceptFiles(Form1.Handle, True); end; procedure TForm1.WMDROPFILES(var Message: TWMDROPFILES); var NumFiles : longint; i : longint; buffer : array[0..255] of char; begin {How many files are being dropped} NumFiles := DragQueryFile(Message.Drop, -1, nil, 0); {Accept the dropped files} for i := 0 to (NumFiles - 1) do begin DragQueryFile(Message.Drop, i, @buffer, sizeof(buffer)); Form1.Memo1.Lines.Add(buffer); end; end; end.
Вопрос:
Как создать задержку не подвешивая
систему без компонента TTimer ?
Ответ:
В примере используется вызов
Application.ProcessMessages для того, чтобы Windows
обрабатывал сообщения во время
цикла задержки.
procedure Delay(ms : longint); var TheTime : LongInt; begin TheTime := GetTickCount + ms; while GetTickCount < TheTime do Application.ProcessMessages; end; procedure TForm1.Button1Click(Sender: TObject); begin ShowMessage('Start Test'); Delay(2000); ShowMessage('End Test'); end;
Вопрос:
Как програмно перезагрузить Windows? Ответ:
Используйте функцию ExitWindows(). В качестве первого параметра ей передается она из трех констант: EW_RESTARTWINDOWS EW_REBOOTSYSTEM EW_EXITANDEXECAPP Второй параметр используется для перезагрузки компьютера в режиме эмуляции MS DOS.
Пример:
ExitWindows(EW_RESTARTWINDOWS, 0 );