WinAPI функции в Delphi

[ WinAPI ]

Программное выключение монитора.
Мигающий заголовок окна.
Закрытие всплывающего меню в приложении 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 < TheTime do
                 Application.ProcessMessages;
             {$ENDIF}
             end;

             procedure TForm1.Button1Click(Sender: TObject);
             begin
               MessageBeep(word(-1));
               Delay(200);
               MessageBeep(word(-1));
               Delay(200);
               MessageBeep(word(-1));
             end;
Наверх к содержанию
Вопрос:
Можно ли отключить кнопку закрытия любого окна?
Ответ:
Да, приведенный пример отключает кнопку закрытия и пункт "закрыть" ситсемного меню заданного окна.
            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 );
Наверх к содержанию