DELPHI WinAPI FAQ



  • Вопрос:
    Как программно выключить монитор?

    Ответ:
    Программно можно отключить монитор совместимый со стандартом 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 );
    Наверх к содержанию


    К списку статей


    Есть комментарии, вопросы, ссылки на полезные ресурсы? Все это можно указать здесь:

    E-mail для ответа:

    Сообщение:


    Материалы находятся на сайте https://exelab.ru/pro/



    Видеокурс ВЗЛОМ