FAQs


Программное выключение монитора.
Мигающий заголовок окна.
Закрытие всплывающего меню в приложении system tray.
Текущее время и дата по Гринвичу.
Способ быстрой очистки canvasа .
Использование InvalidateRect()t для перерисовки всей формы.
Использование процедуры mouse_event() .
Программное закрытие другого приложения.
Форматирование диска.
Отключение кнопки 'Пуск'.
Отключение обновления окна.
Программная установка драйвера принтера.
Как набрать номер с помощью модема в Win32.
Использование Tapi (Telephony API).
Показ иконки, ассоциированной с данным типом файла.
Определение нажатия определенной клавиши во время загрузки приложения.
Звуки из динамика.
Отключение кнопки закрытия любого окна.
Как узнать путь к каталогам Windows.
Как узнать полный путь и имя файла загруженной DLL.
Вызов диалога 'Найти файлы и паки' проводника.
MDI - родительское окно с фоновым рисунком.
Как перехватить нажатие кнопки PrintScreen в Windows.
Определение числа заданий spoolerа печати.
Как определить имена установленых Com-портов.
Извлечение пиктограммы из exe, dll или ico-файла.
Обновление Рабочего Стола Windows.
Отключение перерисовки содержимого окна при перемещении.
Передача процессорных циклов другим приложениям.
Запуск программы на старте Windows.
Увеличение процессорного времени, выделяемого программе.
Определение момента окончания изменения размера окна.
Определение времени последнего доступа к файлу.
Использование функции Shell API SHBrowseForFolder.
Получение дескриптора окна Window, сожержащего DOS программу.
Определение факта изменения системного времени.
Очистка пункта Документы меню кнопки Пуск .
Опеределение состояния модема под Win32.
Добавление пункта к системному меню.
Создание нестандартной процедуры разбиения слов.
Копирование файлов, используя стандартный диалог Копирование Файла Windows.
Как узнать серийный номер диска.
Как узнать тип диска.
Проверка готовности диска.
Использование FindFirst для поиска файлов.
Получение дескриптора окна другого приложения.
Создание не-VCL консольного поекта.
Ошибка внешней функции при передаче параметров типа boolean.
Как получить длинное имя файла .
Временное отключение range checking .
Получение имени файла и пути локальной таблицы.
Получение дескриптора панели задач (TaskBar).
Запуск Screen saver'а програмно.
Установлены ли TrueType шрифты.
Как послать файл в корзину.
Обои рабочего стола.
Запущен ли Delphi.
Версия Windows.
Переменные окружения DOS.
Рисовать на Рабочем столе.
Каталог Windows.
Размер Рабочего стола.
Как закрыть CD.
Определение свободного дискового пространства.
Как спрятать Windows Taskbar.
Машина в сети.
Добавить документ в меню ПУСК ДОКУМЕНТЫ.
Изменить порт принтера.
Определить измения оборудования PlugNPlay.
Изменения в ini-файле.
Как открыть Проводником кокретный каталог.
Запустить аплет панели управления.
Цветная печать.
Открыть URL установленным браузером.
Стереть ехе-файл во время выполнения.
Програмно добавить шрифты True Type.
Часовые пояса.
Использование функции GetTimeZoneInformation.
Прозрачный текст.
Информация о версии файла.
Как создать иконку из bitmap'а.
Преобразование цвета в оттенки серого.
Как держать приложение в минимизированном виде.
Вызов функции RegisterClass .
drag &drop файлов.
Создание задержки без таймера.
Перезапуск Windows.





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

Ответ:
Программно можно отключить монитор совместимый со стандартом EnergyStar.

Отправьте сообщение wm_SysCommand с параметром WParam = SC_MonitorPower

   и LParam = 0 для отключения монитора 
     LParam = 1 для включения монитора


В приведенном примере монитор отключается на 10 секунд.

Пример:


             type 
               TForm1 = class(TForm) 
                 Button1: TButton; 
                 Timer1: TTimer; 
                 procedure FormCreate(Sender: TObject); 
                 procedure Timer1Timer(Sender: TObject); 
                 procedure Button1Click(Sender: TObject); 
               private 
                 { Private declarations } 
               public 
                 MonitorOff : bool; 
                 { Public declarations } 
               end; 
 
             var 
               Form1: TForm1; 
 
             implementation 
 
             {$R *.DFM} 
 
             procedure TForm1.FormCreate(Sender: TObject); 
             begin 
               Timer1.Enabled := false; 
               Timer1.Interval := 10000; 
               MonitorOff := false; 
             end; 
 
             procedure TForm1.Timer1Timer(Sender: TObject); 
             begin 
               if MonitorOff then begin 
                 MonitorOff := false; 
                 SendMessage(Application.Handle, 
                             wm_SysCommand, 
                             SC_MonitorPower, 
                             -1); 
                 Timer1.Enabled := false; 
               end; 
             end; 
 
             procedure TForm1.Button1Click(Sender: TObject); 
             begin 
               MonitorOff := true; 
               Timer1.Enabled := true; 
               SendMessage(Application.Handle, 
                           wm_SysCommand, 
                           SC_MonitorPower, 
                           0); 
             end; 

Наверх к содержанию


Вопрос:

Как создать мигающий заголовок окна (пиктограмму)?
Ответ:
Можно воспользоваться функцией API FlashWindow():

Пример
:

 
             var 
               Flash : bool; 
 
             procedure TForm1.Timer1Timer(Sender: TObject); 
             begin 
               FlashWindow(Form1.Handle, Flash); 
               FlashWindow(Application.Handle, Flash); 
               Flash := not Flash; 
             end; 
 
             procedure TForm1.FormCreate(Sender: TObject); 
             begin 
              Flash := False; 
             end; 

Наверх к содержанию


Вопрос:

Иногда всплывающее меню моего приложения system tray не исчезает когда оно теряет фокус. Как закрыть его?
Ответ:
При показе всплывающего меню установите foreground window, затем пошлите сообщение WM_NULL после показа меню.

             procedure TForm1.WndProc(var Msg : TMessage); 
             var 
               p : TPoint; 
             begin 
               case Msg.Msg of 
                 WM_USER + 1: 
                 case Msg.lParam of 
                   WM_RBUTTONDOWN: begin 
                      SetForegroundWindow(Handle); 
                      GetCursorPos(p); 
                      PopupMenu1.Popup(p.x, p.y); 
                      PostMessage(Handle, WM_NULL, 0, 0); 
                   end; 
                 end; 
               end; 
               inherited; 
             end; 

Наверх к содержанию


Вопрос:

Как узнать текущие время и дату по Гринвичу
Ответ:
Используя API фукцию GetSystemTime.

Пример
:

             procedure TForm1.Button1Click(Sender: TObject); 
             var 
               lt : TSYSTEMTIME; 
               st : TSYSTEMTIME; 
             begin 
               GetLocalTime(lt); 
               GetSystemTime(st); 
               Memo1.Lines.Add('LocalTime = ' + 
                               IntToStr(lt.wmonth) + '/' + 
                               IntToStr(lt.wDay) +  '/' + 
                               IntToStr(lt.wYear) + ' ' + 
                               IntToStr(lt.wHour) +  ':' + 
                               IntToStr(lt.wMinute) +  ':' + 
                               IntToStr(lt.wSecond)); 
               Memo1.Lines.Add('UTCTime = ' + 
                               IntToStr(st.wmonth) + '/' + 
                               IntToStr(st.wDay) +  '/' + 
                               IntToStr(st.wYear) + ' ' + 
                               IntToStr(st.wHour) +  ':' + 
                               IntToStr(st.wMinute) +  ':' + 
                               IntToStr(st.wSecond)); 
             end; 

Наверх к содержанию


Вопрос:

Какой самый быстрый способ для очистки canvasа?
Ответ:
Windows API функция PatBlt().
Пример
:

             procedure TForm1.Button1Click(Sender: TObject); 
             begin 
               PatBlt(Form1.Canvas.Handle, 
                      0, 
                      0, 
                      Form1.ClientWidth, 
                      Form1.ClientHeight, 
                      WHITENESS); 
             end; 

Наверх к содержанию


Вопрос:
При изменении размеров формы мне необходимо чтобы перерисовывалась вся ее поверхность. Но свойство Canvas.ClipRect у формы - только для чтения.
Ответ:
На событии Resize вызовите Windows API функцию InvalidateRect(). Если передать nil в качестве второго параметра приведет к тому, что перерисовываться будет вся клиентская область окна. Третий параметр указывает будет ли перерисовываться фон формы.
Пример
:

            procedure TForm1.FormResize(Sender: TObject); 
             begin 
               InvalidateRect(Form1.Handle, nil, false); 
             end; 
 

Наверх к содержанию


Вопрос:
Как использовать процедуру mouse_event() для имитации событий мыши?
Ответ:
Приведенный пример демонстрирует использование API функции mouse_event() для имитации событий мыши. При нажатии кнопки Button2 программа перемещает курсор мыши на кнопку Button1 и щелкает по ней. Положение курсора мыши задается в "абсолютных" координатах ("Mickeys"), где 65535 "Mickeys" равно ширине экрана.

            procedure TForm1.Button1Click(Sender: TObject); 
             begin 
               ShowMessage('Button 1 clicked'); 
             end; 
 
             procedure TForm1.Button2Click(Sender: TObject); 
             var 
               Pt : TPoint; 
             begin 
              {Позволим кнопке Button2 перерисоваться} 
               Application.ProcessMessages; 
              {Найдем координаты центра button 1} 
               Pt.x := Button1.Left + (Button1.Width div 2); 
               Pt.y := Button1.Top + (Button1.Height div 2); 
              {Преобразуем Pt к координатам экрана} 
               Pt := ClientToScreen(Pt); 
              {Преобразуем Pt к "mickeys" (аболютным координатам курсора мышки} 
               Pt.x := Round(Pt.x * (65535 / Screen.Width)); 
               Pt.y := Round(Pt.y * (65535 / Screen.Height)); 
              {Переместим курсор мыши} 
               Mouse_Event(MOUSEEVENTF_ABSOLUTE or 
                           MOUSEEVENTF_MOVE, 
                           Pt.x, 
                           Pt.y, 
                           0, 
                           0); 
              {Имитируем нажатие левой кнопки мыши} 
               Mouse_Event(MOUSEEVENTF_ABSOLUTE or 
                           MOUSEEVENTF_LEFTDOWN, 
                           Pt.x, 
                           Pt.y, 
                           0, 
                           0);; 
              {Имитируем отпускание левой кнопки мыши} 
               Mouse_Event(MOUSEEVENTF_ABSOLUTE or 
                           MOUSEEVENTF_LEFTUP, 
                           Pt.x, 
                           Pt.y, 
                           0, 
                           0);; 
             end; 

Наверх к содержанию


Вопрос:
Как программно закрыть другое приложение?
Ответ:
Отправьте этому приложению сообщение WM_QUIT
Пример
:


PostMessage(FindWindow(Nil, 'Заголовок окна'), WM_QUIT, 0, 0); 
 
Где "Заголовок окна" - заголовок окна, которому Вы посылаете сообщение. 
 

Наверх к содержанию


Вопрос:
Форматирование диска в Win32
Ответ:
ShellAPI функция ShFormatDrive().
Пример
:

const SHFMT_DRV_A = 0; 
 const SHFMT_DRV_B = 1; 
 
 const SHFMT_ID_DEFAULT = $FFFF; 
 
 const SHFMT_OPT_QUICKFORMAT = 0; 
 const SHFMT_OPT_FULLFORMAT = 1; 
 const SHFMT_OPT_SYSONLY = 2; 
 
 const SHFMT_ERROR = -1; 
 const SHFMT_CANCEL = -2; 
 const SHFMT_NOFORMAT = -3; 
 
 function SHFormatDrive(hWnd : HWND; 
                        Drive : Word; 
                        fmtID : Word; 
                        Options : Word) : Longint 
    stdcall; external 'Shell32.dll' name 'SHFormatDrive'; 
 
 procedure TForm1.Button1Click(Sender: TObject); 
 var 
   FmtRes : longint; 
 begin 
   try 
     FmtRes:= ShFormatDrive(Handle, 
                            SHFMT_DRV_A, 
                            SHFMT_ID_DEFAULT, 
                            SHFMT_OPT_QUICKFORMAT); 
     case FmtRes  of 
      SHFMT_ERROR : ShowMessage('Error formatting the drive'); 
      SHFMT_CANCEL :  
        ShowMessage('User canceled formatting the drive'); 
      SHFMT_NOFORMAT : ShowMessage('No Format') 
     else 
      ShowMessage('Disk has been formatted'); 
     end; 
   except 
   end; 
 
 end; 

Наверх к содержанию


Вопрос:
Как спрятать и отключить кнопку "Пуск"?
Ответ:
Приведенный пример прячет и показывает кнопку "Пуск", а также разрешает и запрещает ее.
Пример
:

            procedure TForm1.Button1Click(Sender: TObject); 
             var 
               Rgn : hRgn; 
             begin 
              {Cпрятать кнопку "Пуск"} 
               Rgn := CreateRectRgn(0, 0, 0, 0); 
               SetWindowRgn(FindWindowEx(FindWindow('Shell_TrayWnd', nil), 
                                                    0, 
                                                   'Button', 
                                                    nil), 
                                                    Rgn, 
                                                    true); 
             end; 
 
             procedure TForm1.Button2Click(Sender: TObject); 
             begin 
              {Показать кнопку "Пуск"} 
               SetWindowRgn(FindWindowEx(FindWindow('Shell_TrayWnd', nil), 
                                                    0, 
                                                   'Button', 
                                                    nil), 
                                                    0, 
                                                    true); 
             end; 
 
             procedure TForm1.Button3Click(Sender: TObject); 
             begin 
              {Запретить кнопку "Пуск"} 
               EnableWindow(FindWindowEx(FindWindow('Shell_TrayWnd', nil), 
                                                    0, 
                                                    'Button', 
                                                    nil), 
                                                    false); 
             end; 
 
             procedure TForm1.Button4Click(Sender: TObject); 
             begin 
              {Разрешить кнопку "Пуск"} 
               EnableWindow(FindWindowEx(FindWindow('Shell_TrayWnd', nil), 
                                                    0, 
                                                    'Button', 
                                                    nil), 
                                                    true); 
             end 
 

Наверх к содержанию


Вопрос:
Как временно отключить перерисовку окна?
Ответ:
Вызовите функцию WinAPI LockWindowUpdate передав ей дескриптор окна, которое необходимо не обновлять. Передайте ноль в качестве параметра для восстановления нормального обновления.

               LockWindowUpdate(Memo1.Handle); 
               . 
               . 
               LockWindowUpdate(0); 

Наверх к содержанию


Вопрос:
Моя программа использует дравер принтера. Возможно ли потихоньку установить драйвер принтера без вмешательства пользователя?
Ответ:
Приведенный пример устанавливает драйвер принтера. Вам необходимо скопировать файлы с драйвером принтера в каталог Windows\System и внести необходимые изменения в файл Win.Ini.

            Примечание: 
              
                DriverName = Имя драйвера; 
                DRVFILE - имя файла с драйвером без расширения 
                          (".drv" - по умолчанию). 


Пример:

             procedure TForm1.Button1Click(Sender: TObject); 
             var 
               s : array[0..64] of char; 
             begin 
               WriteProfileString('PrinterPorts', 
                                  'DriverName', 
                                  'DRVFILE,FILE:,15,45'); 
               WriteProfileString('Devices', 
                                  'DriverName', 
                                  'DRVFILE,FILE:'); 
               StrCopy(S, 'PrinterPorts'); 
               SendMessage(HWND_BROADCAST, WM_WININICHANGE, 0, LongInt(@S)); 
               StrCopy(S, 'Devices'); 
               SendMessage(HWND_BROADCAST, WM_WININICHANGE, 0, LongInt(@S)); 
             end; 

Наверх к содержанию


Вопрос:
Как набрать номер с помощью модема в Win32?
Ответ:
Используйте функцию Windows API CreateFile() чтобы получить дескриптор порта, и стандартные функции ввода-вывода для связи с полученным портом.
Пример
:

             var 
               hCommFile : THandle; 
 
             procedure TForm1.Button1Click(Sender: TObject); 
             var 
               PhoneNumber : string; 
               CommPort : string; 
               NumberWritten : LongInt; 
             begin 
               PhoneNumber := 'ATDT 1-555-555-1212' + #13 + #10; 
               CommPort := 'COM2'; 
              {Open the comm port} 
               hCommFile := CreateFile(PChar(CommPort), 
                                       GENERIC_WRITE, 
                                       0, 
                                       nil, 
                                       OPEN_EXISTING, 
                                       FILE_ATTRIBUTE_NORMAL, 
                                       0); 
               if hCommFile=INVALID_HANDLE_VALUE then 
               begin 
                 ShowMessage('Unable to open '+ CommPort); 
                 exit; 
               end; 
 
              {Dial the phone} 
               NumberWritten:=0; 
               if WriteFile(hCommFile, 
                            PChar(PhoneNumber)^, 
                            Length(PhoneNumber), 
                            NumberWritten, 
                           nil) = false then begin 
                 ShowMessage('Unable to write to ' + CommPort); 
               end; 
             end; 
 
             procedure TForm1.Button2Click(Sender: TObject); 
             begin 
              {Close the port} 
               CloseHandle(hCommFile); 
             end; 

Наверх к содержанию


Вопрос:
Как использовать TAPI для голосового звонка?
Ответ:
См пример.
Пример
:

             {tapi Errors} 
              const TAPIERR_CONNECTED          = 0; 
              const TAPIERR_DROPPED            = -1; 
              const TAPIERR_NOREQUESTRECIPIENT = -2; 
              const TAPIERR_REQUESTQUEUEFULL   = -3; 
              const TAPIERR_INVALDESTADDRESS   = -4; 
              const TAPIERR_INVALWINDOWHANDLE  = -5; 
              const TAPIERR_INVALDEVICECLASS   = -6; 
              const TAPIERR_INVALDEVICEID      = -7; 
              const TAPIERR_DEVICECLASSUNAVAIL = -8; 
              const TAPIERR_DEVICEIDUNAVAIL    = -9; 
              const TAPIERR_DEVICEINUSE        = -10; 
              const TAPIERR_DESTBUSY           = -11; 
              const TAPIERR_DESTNOANSWER       = -12; 
              const TAPIERR_DESTUNAVAIL        = -13; 
              const TAPIERR_UNKNOWNWINHANDLE   = -14; 
              const TAPIERR_UNKNOWNREQUESTID   = -15; 
              const TAPIERR_REQUESTFAILED      = -16; 
              const TAPIERR_REQUESTCANCELLED   = -17; 
              const TAPIERR_INVALPOINTER       = -18; 
 
             {tapi size constants} 
              const TAPIMAXDESTADDRESSSIZE      = 80; 
              const TAPIMAXAPPNAMESIZE          = 40; 
              const TAPIMAXCALLEDPARTYSIZE      = 40; 
              const TAPIMAXCOMMENTSIZE          = 80; 
              const TAPIMAXDEVICECLASSSIZE      = 40; 
              const TAPIMAXDEVICEIDSIZE         = 40; 
 
             function tapiRequestMakeCallA(DestAddress : PAnsiChar; 
                                           AppName : PAnsiChar; 
                                           CalledParty : PAnsiChar; 
                                           Comment : PAnsiChar) : LongInt; 
               stdcall; external 'TAPI32.DLL'; 
 
             function tapiRequestMakeCallW(DestAddress : PWideChar; 
                                           AppName : PWideChar; 
                                           CalledParty : PWideChar; 
                                           Comment : PWideChar) : LongInt; 
               stdcall; external 'TAPI32.DLL'; 
 
             function tapiRequestMakeCall(DestAddress : PChar; 
                                          AppName : PChar; 
                                          CalledParty : PChar; 
                                          Comment : PChar) : LongInt; 
               stdcall; external 'TAPI32.DLL'; 
 
             procedure TForm1.Button1Click(Sender: TObject); 
             var 
               DestAddress : string; 
               CalledParty : string; 
               Comment : string; 
             begin 
               DestAddress := '1-555-555-1212'; 
               CalledParty := 'Frank Borland'; 
               Comment := 'Calling Frank'; 
               tapiRequestMakeCall(pChar(DestAddress), 
                                   PChar(Application.Title), 
                                   pChar(CalledParty), 
                                   PChar(Comment)); 
 
             end; 
 
             end. 

Наверх к содержанию


Вопрос:
Как показать иконку, ассоциированной с данным типом файла?
Ответ:
ShellApi функция ExtractAssociatedIcon()
Пример
:

            uses ShellApi; 
 
             procedure TForm1.Button1Click(Sender: TObject); 
             var 
               Icon : hIcon; 
               IconIndex : word; 
 
             begin 
               IconIndex := 1; 
               Icon := ExtractAssociatedIcon(HInstance, 
                                            Application.ExeName, 
                                            IconIndex); 
              DrawIcon(Canvas.Handle, 10, 10, Icon); 
             end; 
 

Наверх к содержанию


Вопрос:
Как определение нажатия определенной клавиши во время загрузки приложения?
Ответ:
Используйту WinAPI функцию GetKeyState() для определения нажатия клавиши в тексте проекта. Для того чтобы увидеть текст файла проекта в главном меню Delphi 3 выберите "View""ProjectSource" в Delphi 4 "Project""View Source".
Пример
:

             program Project1; 
 
             uses 
               Windows, 
               Forms, 
               Unit1 in 'Unit1.pas' {Form1}; 
 
             {$R *.RES} 
 
             begin 
               if GetKeyState(vk_F8) < 1 then 
                MessageBox(0, 'F8 was pressed during startup', 'MyApp', mb_ok); 
               Application.Initialize; 
               Application.CreateForm(TForm1, Form1); 
               Application.Run; 
             end. 

Наверх к содержанию


Вопрос:
Как заставить пикнуть динамик несколько раз с небольшой задержкой между сигналами, не зависящей от тактовой частоты процессора?
Ответ:
См. пример.
Пример
:

             procedure Delay(ms : longint); 
             {$IFNDEF WIN32} 
             var 
               TheTime : LongInt; 
             {$ENDIF} 
             begin 
             {$IFDEF WIN32} 
               Sleep(ms); 
             {$ELSE} 
               TheTime := GetTickCount + ms; 
               while GetTickCount 

Наверх к содержанию


Вопрос:
Можно ли отключить кнопку закрытия любого окна?
Ответ:
Да, приведенный пример отключает кнопку закрытия и пункт "закрыть" ситсемного меню заданного окна.

            procedure TForm1.Button1Click(Sender: TObject); 
             var 
               hwndHandle : THANDLE; 
               hMenuHandle : HMENU; 
             begin 
               hwndHandle := FindWindow(nil, 'Untitled - Notepad'); 
               if (hwndHandle <> 0) then begin 
                 hMenuHandle := GetSystemMenu(hwndHandle, FALSE); 
                 if (hMenuHandle <> 0) then 
                   DeleteMenu(hMenuHandle, SC_CLOSE, MF_BYCOMMAND); 
               end; 
             end; 
 

Наверх к содержанию


Вопрос:
Как узнать путь к каталогам Windows?
Ответ:
Следующий пример получает полный список каталогов по умолчанию (Favorites, Desktop, Programs, Fonts, SendTo, Start, Menu, Templates, Startup, Recent and NetHood) Windows и заносит его в Memo.
Пример
:

             uses Registry; 
 
             procedure TForm1.Button1Click(Sender: TObject); 
             var 
               reg : TRegistry; 
               ts : TStrings; 
               i : integer; 
             begin 
               reg := TRegistry.Create; 
               reg.RootKey := HKEY_CURRENT_USER; 
               reg.LazyWrite := false; 
               reg.OpenKey( 
                'Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders', 
                           false); 
                 ts := TStringList.Create; 
                 reg.GetValueNames(ts); 
                 for i := 0 to ts.Count -1 do begin 
                   Memo1.Lines.Add(ts.Strings[i] + 
                                   ' = ' + 
                                   reg.ReadString(ts.Strings[i])); 
                 end; 
                 ts.Free; 
               reg.CloseKey; 
               reg.free; 
             end; 

Наверх к содержанию


Вопрос:
Как узнать полный путь и имя файла загруженной DLL?
Ответ:
См. пример
Пример
:

 
             uses Windows; 
 
             procedure ShowDllPath stdcall; 
             var 
               TheFileName : array[0..MAX_PATH] of char; 
             begin 
               FillChar(TheFileName, sizeof(TheFileName), #0); 
               GetModuleFileName(hInstance, TheFileName, sizeof(TheFileName)); 
               MessageBox(0, TheFileName, 'The DLL file name is:', mb_ok); 
             end; 

Наверх к содержанию


Вопрос:
Как вызвать диалог 'Найти файлы и паки' проводника?
Ответ:
Приведенный пример показывает использование DDE для вызова диалога 'Найти файлы и паки' Explorerа. Диалог открывается на каталоге "C:\Download".

            procedure TForm1.Button1Click(Sender: TObject); 
             begin 
               with TDDEClientConv.Create(Self) do begin 
                 ConnectMode := ddeManual; 
                 ServiceApplication := 'explorer.exe'; 
                 SetLink( 'Folders', 'AppProperties'); 
                 OpenLink; 
                 ExecuteMacro('[FindFolder(, C:\DOWNLOAD)]', False); 
                 CloseLink; 
                 Free; 
               end; 
             end; 
 

Наверх к содержанию


Вопрос:
Как сделать родительское окно с фоновым рисунком в клиентской области?
Ответ:
Для того чтобы сделать это выполните следующие шаги:

      Срздайте новый проект. 
      Установите FormStyle формы в fsMDIForm 
      Разместите Image на форме и загрузите в него картинку. 
      Найдите { Private Declarations } в обьявлении формы и добаьте следующие строки: 
 
                 FClientInstance : TFarProc; 
                 FPrevClientProc : TFarProc; 
                 procedure ClientWndProc(var Message: TMessage); 
 
      Добаьте следующие строки в разделе implementation: 
 
             procedure TMainForm.ClientWndProc(var Message: TMessage); 
             var 
               Dc : hDC; 
               Row : Integer; 
               Col : Integer; 
             begin 
               with Message do 
                 case Msg of 
                   WM_ERASEBKGND: 
                   begin 
                     Dc := TWMEraseBkGnd(Message).Dc; 
                     for Row := 0 to ClientHeight div Image1.Picture.Height do 
                       for Col := 0 to ClientWidth div Image1.Picture.Width do 
                         BitBlt(Dc, 
                            Col * Image1.Picture.Width, 
                            Row * Image1.Picture.Height, 
                            Image1.Picture.Width, 
                            Image1.Picture.Height, 
                            Image1.Picture.Bitmap.Canvas.Handle, 
                            0, 
                            0, 
                            SRCCOPY); 
                       Result := 1; 
                   end; 
                   else 
                     Result := CallWindowProc(FPrevClientProc, 
                                              ClientHandle, 
                                              Msg, 
                                              wParam, 
                                              lParam); 
               end; 
             end; 
 
             В методе формы OnCreate добавьте: 
 
                FClientInstance := MakeObjectInstance(ClientWndProc); 
                FPrevClientProc := Pointer(GetWindowLong(ClientHandle, 
                                           GWL_WNDPROC)); 
                SetWindowLong(ClientHandle, 
                              GWL_WNDPROC, LongInt(FClientInstance)); 
 
             Добавьте к проекту новую форму и установите ее свойство FormStyle в 
             fsMDIChild. 
 
             У Вас получился  MDI-проект с "обоями" в клиентской области MDI формы. 

Наверх к содержанию


Вопрос:
Как глобально перехватить нажатие кнопки PrintScreen?
Ответ:
В примере для глобального перехвата нажатия клавиши printscreen регистрируется горячая клавиша (hot key).
Пример
:

            type 
               TForm1 = class(TForm) 
                 procedure FormCreate(Sender: TObject); 
                 procedure FormDestroy(Sender: TObject); 
               private 
                 { Private declarations } 
                 procedure WMHotKey(var Msg : TWMHotKey); message WM_HOTKEY; 
               public 
                 { Public declarations } 
               end; 
 
             var 
               Form1: TForm1; 
 
             implementation 
 
             {$R *.DFM} 
 
             const id_SnapShot = 101; 
 
             procedure TForm1.WMHotKey (var Msg : TWMHotKey); 
             begin 
               if Msg.HotKey = id_SnapShot then 
                 ShowMessage('GotIt'); 
             end; 
 
             procedure TForm1.FormCreate(Sender: TObject); 
             begin 
               RegisterHotKey(Form1.Handle, 
                              id_SnapShot, 
                              0, 
                              VK_SNAPSHOT); 
             end; 
 
             procedure TForm1.FormDestroy(Sender: TObject); 
             begin 
               UnRegisterHotKey (Form1.Handle, id_SnapShot); 
             end; 
 

Наверх к содержанию


Вопрос:
Существует ли способ для определение числа заданий spoolerа печати?
Ответ:
Spoolerа печати Windows посылает WM_SPOOLERSTATUS каждый раз при добавлении и удалении заданий в очереди печати. В следующем примере показано как перехватить это сообщение
Пример
:

             type 
               TForm1 = class(TForm) 
                 Label1: TLabel; 
               private 
                 { Private declarations } 
                 procedure WM_SpoolerStatus(var Msg : TWMSPOOLERSTATUS); 
                   message WM_SPOOLERSTATUS; 
               public 
                 { Public declarations } 
               end; 
 
             var 
               Form1: TForm1; 
 
             implementation 
 
             {$R *.DFM} 
 
             procedure TForm1.WM_SpoolerStatus(var Msg : TWMSPOOLERSTATUS); 
             begin 
               Lable1.Caption := IntToStr(msg.JobsLeft) + 
                                 ' Jobs currenly in spooler'; 
               msg.Result := 0; 
             end; 

Наверх к содержанию


Вопрос:
Как определить имена установленых Com-портов?
Ответ:
Из реестра. См. пример.
Пример
:

             uses Registry; 
 
             procedure TForm1.Button1Click(Sender: TObject); 
             var 
               reg : TRegistry; 
               ts : TStrings; 
               i : integer; 
             begin 
               reg := TRegistry.Create; 
               reg.RootKey := HKEY_LOCAL_MACHINE; 
               reg.OpenKey('hardware\devicemap\serialcomm', 
                           false); 
               ts := TStringList.Create; 
               reg.GetValueNames(ts); 
               for i := 0 to ts.Count -1 do begin 
                 Memo1.Lines.Add(reg.ReadString(ts.Strings[i])); 
               end; 
               ts.Free; 
               reg.CloseKey; 
               reg.free; 
             end; 

Наверх к содержанию


Вопрос:
Извлечение пиктограммы из exe, dll или ico-файла
Ответ:
Функция SHELLAPI ExtractIconEx:
Обратите внимание - в примере функции обьявленны иначе, чем в модуле ShellAPI

             type ThIconArray = array[0..0] of hIcon; 
             type PhIconArray = ^ThIconArray; 
 
             function ExtractIconExA(lpszFile: PAnsiChar; 
                                     nIconIndex: Integer; 
                                     phiconLarge : PhIconArray; 
                                     phiconSmall: PhIconArray; 
                                     nIcons: UINT): UINT; stdcall; 
               external 'shell32.dll' name 'ExtractIconExA'; 
 
             function ExtractIconExW(lpszFile: PWideChar; 
                                     nIconIndex: Integer; 
                                     phiconLarge: PhIconArray; 
                                     phiconSmall: PhIconArray; 
                                     nIcons: UINT): UINT; stdcall; 
               external 'shell32.dll' name 'ExtractIconExW'; 
 
             function ExtractIconEx(lpszFile: PAnsiChar; 
                                    nIconIndex: Integer; 
                                    phiconLarge : PhIconArray; 
                                    phiconSmall: PhIconArray; 
                                    nIcons: UINT): UINT; stdcall; 
               external 'shell32.dll' name 'ExtractIconExA'; 
 
 
            procedure TForm1.Button1Click(Sender: TObject); 
             var 
                 NumIcons : integer; 
                 pTheLargeIcons : phIconArray; 
                 pTheSmallIcons : phIconArray; 
                 LargeIconWidth : integer; 
                 SmallIconWidth : integer; 
                 SmallIconHeight : integer; 
                 i : integer; 
                 TheIcon : TIcon; 
                 TheBitmap : TBitmap; 
             begin 
               NumIcons := 
               ExtractIconEx('C:\Program Files\Borland\Delphi 3\BIN\delphi32.exe', 
                             -1, 
                             nil, 
                             nil, 
                             0); 
               if NumIcons  0 then begin 
                 LargeIconWidth := GetSystemMetrics(SM_CXICON); 
                 SmallIconWidth := GetSystemMetrics(SM_CXSMICON); 
                 SmallIconHeight := GetSystemMetrics(SM_CYSMICON); 
                 GetMem(pTheLargeIcons, NumIcons * sizeof(hIcon)); 
                 GetMem(pTheSmallIcons, NumIcons * sizeof(hIcon)); 
                 FillChar(pTheLargeIcons^, NumIcons * sizeof(hIcon), #0); 
                 FillChar(pTheSmallIcons^, NumIcons * sizeof(hIcon), #0); 
                ExtractIconEx('C:\Program Files\Borland\Delphi 3\BIN\delphi32.exe', 
                               0, 
                               pTheLargeIcons, 
                               pTheSmallIcons, 
                               numIcons); 
                {$IFOPT R+} 
                  {$DEFINE CKRANGE} 
                  {$R-} 
                {$ENDIF} 
                 for i := 0 to (NumIcons - 1) do begin 
                   DrawIcon(Form1.Canvas.Handle, 
                            i * LargeIconWidth, 
                            0, 
                            pTheLargeIcons^[i]); 
                   TheIcon := TIcon. Create; 
                   TheBitmap := TBitmap.Create; 
                   TheIcon.Handle := pTheSmallIcons^[i]; 
                   TheBitmap.Width := TheIcon.Width; 
                   TheBitmap.Height := TheIcon.Height; 
                   TheBitmap.Canvas.Draw(0, 0, TheIcon); 
                   TheIcon.Free; 
                   Form1.Canvas.StretchDraw(Rect(i * SmallIconWidth, 
                                                 100, 
                                                 (i + 1) * SmallIconWidth, 
                                                 100 + SmallIconHeight), 
                                            TheBitmap); 
                   TheBitmap.Free; 
                 end; 
                {$IFDEF CKRANGE} 
                  {$UNDEF CKRANGE} 
                  {$R+} 
                {$ENDIF} 
                 FreeMem(pTheLargeIcons, NumIcons * sizeof(hIcon)); 
                 FreeMem(pTheSmallIcons, NumIcons * sizeof(hIcon)); 
               end; 
             end; 
 
             end. 

Наверх к содержанию


Вопрос:
как заставить Рабочий Стола Windows обновится?
Ответ:
См. пример.
Пример
:

             procedure TForm1.Button1Click(Sender: TObject); 
             begin 
               SendMessage(FindWindow('Progman', 'Program Manager'), 
                           WM_COMMAND, 
                           $A065, 
                           0); 
             end; 

Наверх к содержанию


Вопрос:
Перерисовка canvasf моей формы занимает довольно много времени. Как определить установлен ли у пользователя режим перерисовки всего окна при перемещении чтобы временно отключить перерисовку моего окна?
Ответ:
В приведенном примере определяется включен ли режим "Full Window Drag" (перерисовки всего окна при перемещении)
Пример
:

             procedure TForm1.Button1Click(Sender: TObject); 
             var 
               b : bool; 
             begin 
               SystemParametersInfo(SPI_GETDRAGFULLWINDOWS, 0, @b, 0); 
               if not b then 
                 ShowMessage('Full Window Drag is not enabled') else 
                 ShowMessage('Full Window Drag is enabled'); 
             end; 

Наверх к содержанию


Вопрос:
Как уступить выделенный моей программе квант процессорного времени другим приложениям?
Ответ:
Вызовите функцию Windows API Sleep() передав ноль в качестве параметра.
Наверх к содержанию


Вопрос:
Как запускать мою программу на каждом старте Windows?
Ответ
:
Пример работает и для Win32и для Win16.

             uses 
               Registry, {For Win32} 
               IniFiles; {For Win16} 
 
             {$IFNDEF WIN32} 
               const MAX_PATH = 144; 
             {$ENDIF} 
 
             {For Win32} 
             procedure TForm1.Button1Click(Sender: TObject); 
             var 
               reg: TRegistry; 
             begin 
               reg := TRegistry.Create; 
               reg.RootKey := HKEY_LOCAL_MACHINE; 
               reg.LazyWrite := false; 
               reg.OpenKey('Software\Microsoft\Windows\CurrentVersion\Run', 
                           false); 
               reg.WriteString('My App', Application.ExeName); 
               reg.CloseKey; 
               reg.free; 
             end; 
 
             {For Win16} 
             procedure TForm1.Button2Click(Sender: TObject); 
             var 
               WinIni : TIniFile; 
               WinIniFileName : array[0..MAX_PATH] of char; 
               s : string; 
             begin 
               GetWindowsDirectory(WinIniFileName, sizeof(WinIniFileName)); 
               StrCat(WinIniFileName, '\win.ini'); 
               WinIni := TIniFile.Create(WinIniFileName); 
               s := WinIni.ReadString('windows', 
                                      'run', 
                                      ''); 
               if s = '' then 
                 s := Application.ExeName else 
                 s := s + ';' + Application.ExeName; 
               WinIni.WriteString('windows', 
                                  'run', 
                                  s); 
               WinIni.Free; 
             end; 

Наверх к содержанию


Вопрос:
Как увеличить процессорное время, выделяемого программе?
Ответ:
Следующий пример изменяет приоритет приложения. Изменение приоритета следует использовать с осторожностью - т.к. присвоение слишком высокого приоритета может привети к медленной работе остальных программ и системы в целом. См. Win32 help for SetThreadPriority() function.
Пример
:

             procedure TForm1.Button1Click(Sender: TObject); 
             var 
               ProcessID : DWORD; 
               ProcessHandle : THandle; 
               ThreadHandle : THandle; 
             begin 
               ProcessID := GetCurrentProcessID; 
               ProcessHandle := OpenProcess(PROCESS_SET_INFORMATION, 
                                            false, 
                                            ProcessID); 
               SetPriorityClass(ProcessHandle, REALTIME_PRIORITY_CLASS); 
               ThreadHandle := GetCurrentThread; 
               SetThreadPriority(ThreadHandle, THREAD_PRIORITY_TIME_CRITICAL); 
             end; 

Наверх к содержанию


Вопрос:
Я хочу определить момент окончания изменения размера или перемещения окна. Перехватываю сообщения WM_SIZE и WM_MOVE но я получаю много таких сообщений а мне нужно узнать когда именно пользователь закончил перенос или изменение размеров окна. Возможно ли это?
Ответ:
В следующем примере показан перехват сообщения WM_EXITSIZEMOVE Хотя сообщение документированно только для Windows NT оно работает точно так же и под Windows 95. Обратите внимание что Вы можите перехватить сообщение WM_ENTERSIZEMOVEдля определения момента начала пользователем операции изменения размера или перемещения окна
.
Пример:

             type 
               TForm1 = class(TForm) 
               private 
                 { Private declarations } 
               public 
                 procedure WMEXITSIZEMOVE(var Message: TMessage); 
                    message WM_EXITSIZEMOVE; 
                 { Public declarations } 
               end; 
 
             var 
               Form1: TForm1; 
 
             implementation 
 
             {$R *.DFM} 
             procedure TForm1.WMEXITSIZEMOVE(var Message: TMessage); 
             begin 
               Form1.Caption := 'Finished Moving and sizing'; 
             end; 

Наверх к содержанию


Вопрос:
Как определить время последнего доступа к файлу?
Ответ:
См пример. Примечание: не все файловые системы поддерживают время последнего доступа к файлу.
Пример
:

             procedure TForm1.Button1Click(Sender: TObject); 
             var 
               SearchRec : TSearchRec; 
               Success : integer; 
               DT : TFileTime; 
               ST : TSystemTime; 
             begin 
               Success := SysUtils.FindFirst('C:\autoexec.bat', 
                                             faAnyFile, 
                                             SearchRec); 
              if (Success = 0) and 
                   (( SearchRec.FindData.ftLastAccessTime.dwLowDateTime <> 0) 
                   or ( SearchRec.FindData.ftLastAccessTime.dwHighDateTime <> 0)) 
              then 
               begin 
                 FileTimeToLocalFileTime(SearchRec.FindData.ftLastAccessTime,DT); 
                   FileTimeToSystemTime(DT,ST); 
                 Memo1.Lines.Clear; 
                 Memo1.Lines.Add('AutoExec.Bat was last accessed at:'); 
                 Memo1.Lines.Add('Year := ' + IntToStr(st.wYear)); 
                 Memo1.Lines.Add('Month := ' + IntToStr(st.wMonth)); 
                 Memo1.Lines.Add('DayOfWeek := ' + IntToStr(st.wDayOfWeek)); 
                 Memo1.Lines.Add('Day := ' + IntToStr(st.wDay)); 
                 Memo1.Lines.Add('Hour := ' + IntToStr(st.wHour)); 
                 Memo1.Lines.Add('Minute := ' + IntToStr(st.wMinute)); 
                 Memo1.Lines.Add('Second := ' + IntToStr(st.wSecond)); 
                 Memo1.Lines.Add('Milliseconds := ' + IntToStr(st.wMilliseconds)); 
               end; 
               SysUtils.FindClose(SearchRec); 
             end; 

Наверх к содержанию


Вопрос:
Как использовать функцию Shell API SHBrowseForFolder чтобы позволить пользователю выбрать каталог?
Ответ:
См. пример
Пример
:

             uses ShellAPI, ShlObj; 
 
             procedure TForm1.Button1Click(Sender: TObject); 
             var 
               TitleName : string; 
               lpItemID : PItemIDList; 
               BrowseInfo : TBrowseInfo; 
               DisplayName : array[0..MAX_PATH] of char; 
               TempPath : array[0..MAX_PATH] of char; 
             begin 
               FillChar(BrowseInfo, sizeof(TBrowseInfo), #0); 
               BrowseInfo.hwndOwner := Form1.Handle; 
               BrowseInfo.pszDisplayName := @DisplayName; 
               TitleName := 'Please specify a directory'; 
               BrowseInfo.lpszTitle := PChar(TitleName); 
               BrowseInfo.ulFlags := BIF_RETURNONLYFSDIRS; 
               lpItemID := SHBrowseForFolder(BrowseInfo); 
               if lpItemId <> nil then begin 
                 SHGetPathFromIDList(lpItemID, TempPath); 
                 ShowMessage(TempPath); 
                 GlobalFreePtr(lpItemID); 
               end; 
             end; 

Наверх к содержанию


Вопрос:
Как получить дескриптора окна Window, сожержащего DOS программу или программу консольного режима?
Ответ:
В следуещем примере используется функция Windows API FindWindow(). Обратите внимание, что WndClass консольного окна отличаются для Windows 95 и Window NT и заголовок окна может содержать полный путь под Windows NT.
Пример
:

             procedure TForm1.Button1Click(Sender: TObject); 
             var 
               info : TOSVersionInfo; 
               ClassName : string; 
               Title : string; 
             begin 
              {Проверяем -  Win95 или NT.} 
               info.dwOSVersionInfoSize := sizeof(info); 
               GetVersionEx(info); 
               if (info.dwPlatformId = VER_PLATFORM_WIN32_NT) then begin 
                 ClassName := 'ConsoleWindowClass'; 
                 Title := 'Command Prompt'; 
               end else begin 
                 ClassName := 'tty'; 
                 Title := 'MS-DOS Prompt'; 
               end; 
               ShowMessage(IntToStr(FindWindow(PChar(ClassName), PChar(Title)))); 
             end; 

Наверх к содержанию


Вопрос:
Возможно ли определить факта изменения системного времени другим приложением?
Ответ:
Следующий прмер перехватывает событие WM_TIMECHANGE. примечание: Приложение , изменяющее системное время должно посылать сообщение WM_TIMECHANGE всем окнам
.

 
             type 
               TForm1 = class(TForm) 
               private 
                 { Private declarations } 
                 procedure WMTIMECHANGE(var Message: TWMTIMECHANGE); 
                    message WM_TIMECHANGE; 
               public 
                 { Public declarations } 
               end; 
 
             var 
               Form1: TForm1; 
 
             implementation 
 
             {$R *.DFM} 
 
             procedure TForm1.WMTIMECHANGE(var Message: TWMTIMECHANGE); 
             begin 
               Form1.Caption := 'Time Changed'; 
             end; 

Наверх к содержанию


Вопрос:
Как очистить пункт документы меню кнопки Пуск
Ответ:
Вызовите Windows API функцию SHAddToRecentDocs() передав nil вместо имени файла в качестве параметра.
Пример
:

             uses 
               ShlOBJ; 
 
             procedure TForm1.Button1Click(Sender: TObject); 
             begin 
               SHAddToRecentDocs(SHARD_PATH, nil); 
             end; 

Наверх к содержанию


Вопрос:
Как опеределить состояние модема под Win32?
Ответ:
См. пример
Пример
:

             procedure TForm1.Button1Click(Sender: TObject); 
             var 
               CommPort : string; 
               hCommFile : THandle; 
               ModemStat : DWord; 
             begin 
               CommPort := 'COM2'; 
 
              {Open the comm port} 
               hCommFile := CreateFile(PChar(CommPort), 
                                       GENERIC_READ, 
                                       0, 
                                       nil, 
                                       OPEN_EXISTING, 
                                       FILE_ATTRIBUTE_NORMAL, 
                                       0); 
               if hCommFile = INVALID_HANDLE_VALUE then 
               begin 
                 ShowMessage('Unable to open '+ CommPort); 
                 exit; 
               end; 
 
              {Get the Modem Status} 
               if GetCommModemStatus(hCommFile, ModemStat) <> false then begin 
                 if ModemStat and MS_CTS_ON <> 0 then 
                   ShowMessage('The CTS (clear-to-send) is on.'); 
                 if ModemStat and MS_DSR_ON <> 0 then 
                   ShowMessage('The DSR (data-set-ready) is on.'); 
                 if ModemStat and MS_RING_ON <> 0then 
                   ShowMessage('The ring indicator is on.'); 
                 if ModemStat and MS_RLSD_ON <> 0 then 
                   ShowMessage('The RLSD (receive-line-signal-detect) is  
             on.'); 
             end; 
 
              {Close the comm port} 
               CloseHandle(hCommFile); 
             end; 

Наверх к содержанию


Вопрос:
Как добавить пункт к системному меню приложения?
Пример
:

             type 
               TForm1 = class(TForm) 
                 procedure FormCreate(Sender: TObject); 
               private 
                 { Private declarations } 
                 procedure WMSysCommand(var Msg: TWMSysCommand); 
                   message WM_SYSCOMMAND; 
               public 
                 { Public declarations } 
               end; 
 
             var 
               Form1: TForm1; 
 
             implementation 
 
             {$R *.DFM} 
 
             const 
               SC_MyMenuItem = WM_USER + 1; 
 
             procedure TForm1.FormCreate(Sender: TObject); 
             begin 
               AppendMenu(GetSystemMenu(Handle, FALSE), MF_SEPARATOR, 0, ''); 
               AppendMenu(GetSystemMenu(Handle, FALSE), 
                          MF_STRING, 
                          SC_MyMenuItem, 
                          'My Menu Item'); 
             end; 
 
             procedure TForm1.WMSysCommand(var Msg: TWMSysCommand); 
             begin 
               if Msg.CmdType = SC_MyMenuItem then 
                 ShowMessage('Got the message') else 
                 inherited; 
             end; 

Наверх к содержанию


Вопрос:
Как создание нестандартную процедуру разбиения слов при переносах для TEdit, TMemo или TRichEdit?
Ответ:
В следующем примере создается процедура разбиения слов при переносах для TMemo. Заметьте, что реализованная процедура просто всегда разрешает перенос. Для дополнительной информации см.таже документацию к сообщению EM_SETWORDBREAKPROC.

              var 
               OriginalWordBreakProc : pointer; 
               NewWordBreakProc : pointer; 
 
             function MyWordBreakProc(LPTSTR  : pchar; 
                                      ichCurrent : integer; 
                                      cch : integer; 
                                      code  : integer) : integer 
                {$IFDEF WIN32} stdcall; {$ELSE} ; export; {$ENDIF} 
             begin 
               result :=  0; 
             end; 
 
             procedure TForm1.FormCreate(Sender: TObject); 
             begin 
               OriginalWordBreakProc := Pointer( 
                 SendMessage(Memo1.Handle, 
                             EM_GETWORDBREAKPROC, 
                             0, 
                             0)); 
              {$IFDEF WIN32} 
               NewWordBreakProc := @MyWordBreakProc; 
              {$ELSE} 
                NewWordBreakProc := MakeProcInstance(@MyWordBreakProc, 
                                                     hInstance); 
              {$ENDIF} 
               SendMessage(Memo1.Handle, 
                           EM_SETWORDBREAKPROC, 
                           0, 
                           longint(NewWordBreakProc)); 
 
             end; 
 
             procedure TForm1.FormDestroy(Sender: TObject); 
             begin 
               SendMessage(Memo1.Handle, 
                           EM_SETWORDBREAKPROC, 
                           0, 
                           longint(@OriginalWordBreakProc)); 
              {$IFNDEF WIN32} 
                FreeProcInstance(NewWordBreakProc); 
              {$ENDIF} 
             end; 

Наверх к содержанию


Вопрос:
Можно ли скопировать группу файлов, используя стандартный диалог с анимацией Копирование Файлов, который использует "Проводник" (Explorer)?
Ответ:
В следующем примере используется функция SHFileOperation для копирования группы файлов и показа анимированного диалога. Вы можете использовать также следующие флаги для копирования, удаления, переноса и переименования файлов.

             TO_COPY 
             FO_DELETE 
             FO_MOVE 
             FO_RENAME 

Примечание: буфер, содержащий имена файлов для копирования должен заканчиваться двумя нулевыми символами.
Пример
:

             uses ShellAPI;  
             procedure TForm1.Button1Click(Sender: TObject); 
             var 
              Fo      : TSHFileOpStruct; 
              buffer  : array[0..4096] of char; 
              p       : pchar; 
 
             begin 
               FillChar(Buffer, sizeof(Buffer), #0); 
               p := @buffer; 
               p := StrECopy(p, 'C:\DownLoad\1.ZIP') + 1; 
               p := StrECopy(p, 'C:\DownLoad\2.ZIP') + 1; 
               p := StrECopy(p, 'C:\DownLoad\3.ZIP') + 1; 
               StrECopy(p, 'C:\DownLoad\4.ZIP'); 
 
               FillChar(Fo, sizeof(Fo), #0); 
               Fo.Wnd    := Handle; 
               Fo.wFunc  := FO_COPY; 
               Fo.pFrom  := @Buffer; 
               Fo.pTo    := 'D:\'; 
               Fo.fFlags := 0; 
               if ((SHFileOperation(Fo) <> 0) or 
                   (Fo.fAnyOperationsAborted <> false)) then 
                 ShowMessage('Cancelled') 
             end; 

Наверх к содержанию


Вопрос:
Как узнать серийный номер диска
Ответ
:

             procedure TForm1.Button1Click(Sender: TObject); 
             var 
               VolumeName, 
               FileSystemName     : array [0..MAX_PATH-1] of Char; 
               VolumeSerialNo     : DWord; 
               MaxComponentLength, 
               FileSystemFlags    : Integer; 
             begin 
               GetVolumeInformation('C:\',VolumeName,MAX_PATH,@VolumeSerialNo, 
                                    MaxComponentLength,FileSystemFlags, 
                                    FileSystemName,MAX_PATH); 
               Memo1.Lines.Add('VName = '+VolumeName); 
               Memo1.Lines.Add('SerialNo = $'+IntToHex(VolumeSerialNo,8)); 
               Memo1.Lines.Add('CompLen = '+IntToStr(MaxComponentLength)); 
               Memo1.Lines.Add('Flags = $'+IntToHex(FileSystemFlags,4)); 
               Memo1.Lines.Add('FSName = '+FileSystemName); 
             end; 

Наверх к содержанию


Вопрос:
Как узнать является диск CD-диском,сетевым диском, виртуальным диском или сьемным диском?
Ответ:
Windows API функция GetDriveType().
Пример
:

             procedure TForm1.Button1Click(Sender: TObject); 
             begin 
               case GetDriveType('C:\') of 
                 0              : ShowMessage('The drive type cannot be determined'); 
                 1              : ShowMessage('The root directory does not exist'); 
                 DRIVE_REMOVABLE:ShowMessage('The disk can be removed'); 
                 DRIVE_FIXED    : ShowMessage('The disk cannot be removed'); 
                 DRIVE_REMOTE   : ShowMessage('The drive is remote (network) drive'); 
                 DRIVE_CDROM    : ShowMessage('The drive is a CD-ROM drive'); 
                 DRIVE_RAMDISK  : ShowMessage('The drive is a RAM disk'); 
               end; 
             end; 

Наверх к содержанию


Вопрос:
Как проверить готовность диска без появления окна ошибки Windows?
Ответ:
Вы можете использовать функцию Windows API SetErrorMode() для отключения диалога Window's critical Error.
Пример
:

             function IsDriveReady(DriveLetter : char) : bool; 
             var 
               OldErrorMode : Word; 
               OldDirectory : string; 
             begin 
               OldErrorMode := SetErrorMode(SEM_NOOPENFILEERRORBOX); 
               GetDir(0, OldDirectory); 
               {$I-} 
                 ChDir(DriveLetter + ':\'); 
               {$I+} 
                if IoResult <> 0 then 
                 Result := False  
                else 
                 Result := True; 
 
               ChDir(OldDirectory); 
               SetErrorMode(OldErrorMode); 
             end; 
 
             procedure TForm1.Button1Click(Sender: TObject); 
             begin 
               if not IsDriveReady('A') then 
                 ShowMessage('Drive Not Ready') else 
                 ShowMessage('Drive is Ready'); 
             end; 

Наверх к содержанию


Вопрос:
Использование FindFirst для поиска файлов.
Ответ
:

             begin 
                 Result := SysUtils.FindFirst(Path, Attr, SearchRec); 
                 while Result = 0 do 
                 begin 
                   ProcessSearchRec(SearchRec); 
                   Result :=  SysUtils.FindNext(SearchRec); 
                 end; 
                  SysUtils.FindClose(SearchRec); 
             end; 

Наверх к содержанию


Вопрос:
Как получить дескриптор окна другого приложения и сделать его активным?
Ответ:
Использование фуекции Windows API FindWindow() - простейший способ нахождение окна, при условии, что известен его заголовок или имя оконного класса. Если Вам известна только часть заголовка окна (например 'Netscape - ' + 'какой-то неизвестный URL'), Вам нужно использовать функцию EnumWindows() для получения всех окон, затем вызывать функцию GetWindowsText() и GetClassName для поиска нужного окна. Следующий пример находит первое окно, содержащее совпадающую часть заголовка окна и полностью совпадающее название оконного класса (если он задан) и делает это окно активным.

             type 
               PFindWindowStruct = ^TFindWindowStruct; 
               TFindWindowStruct = record 
                 Caption : string; 
                 ClassName : string; 
                 WindowHandle : THandle; 
               end; 
 
             function EnumWindowsProc(hWindow : hWnd; 
                                      lParam  : LongInt) : Bool 
             {$IFDEF Win32} stdcall; {$ELSE} ; export; {$ENDIF} 
             var 
               lpBuffer : PChar; 
               WindowCaptionFound : bool; 
               ClassNameFound : bool; 
 
             begin 
               GetMem(lpBuffer, 255); 
               Result := True; 
               WindowCaptionFound := False; 
               ClassNameFound := False; 
 
               try 
                 if GetWindowText(hWindow, lpBuffer, 255)  0 then 
                   if Pos(PFindWindowStruct(lParam).Caption, StrPas(lpBuffer))  0 
                    then WindowCaptionFound := true; 
 
                 if PFindWindowStruct(lParam).ClassName = '' then 
                   ClassNameFound := True else 
                     if GetClassName(hWindow, lpBuffer, 255)  0 then 
                       if Pos(PFindWindowStruct(lParam).ClassName, StrPas(lpBuffer)) 
                         0 then ClassNameFound := True; 
 
                 if (WindowCaptionFound and ClassNameFound) then begin 
                   PFindWindowStruct(lParam).WindowHandle := hWindow; 
                   Result := False; 
                 end; 
 
               finally 
                 FreeMem(lpBuffer, sizeof(lpBuffer^)); 
               end; 
             end; 
 
             function FindAWindow(Caption : string; 
                                  ClassName : string) : THandle; 
             var 
               WindowInfo : TFindWindowStruct; 
 
             begin 
               with WindowInfo do begin 
                 Caption := Caption; 
                 ClassName := ClassName; 
                 WindowHandle := 0; 
                 EnumWindows(@EnumWindowsProc, LongInt(@WindowInfo)); 
                 FindAWindow := WindowHandle; 
               end; 
             end; 
 
             procedure TForm1.Button1Click(Sender: TObject); 
             var 
               TheWindowHandle : THandle; 
             begin 
               TheWindowHandle := FindAWindow('Netscape - ', ''); 
               if TheWindowHandle = 0 then 
                 ShowMessage('Window Not Found!') else 
                 BringWindowToTop(TheWindowHandle); 
             end; 

Наверх к содержанию


Вопрос:
Как написать программу не имеющую ни одной формы?
Ответ:
Создайте новое приложение, затем удалите из проекта все unitы - (Delphi 3 - View - Project Manager)
(Delphi 4 - Project - Remove from project)
Откройте файл проекта
(Delphi 3 - View - Project Source)
(Delphi 3 - Project - View Source)
и отредактируйте его так как приведино ниже.

Пример
:

             program Project1; 
 
             {$R *.RES} 
 
             uses SysUtils; 
 
             var 
               f : TextFile; 
 
             begin 
               AssignFile(f, 'TestFile.Txt'); 
               ReWrite(f); 
               Writeln(f, 'Test'); 
               Close(f); 
             end. 

Наверх к содержанию


Вопрос:
Почему возникает ошибка при передаче параметров типа boolean равного True в некоторые внешней функции
Ответ:
В Delphi 3 значение "True" для типов ByteBool, WordBool LongBool представляется как -1 для совместимости с Microsoft Visual Basic. Многие компиляторы представляют "True" как либо "не нуль" либо 1. При передаче параметров в не Visual Basic-приложения Вам следует придерживаться следующей техники во избежание несовместимости:

             LongBool(Abs(True)); 

При приеме значений типа boolean из внешних программ Вам следует всегда проверять его на значение "False". Эта техника всегда работает, поскольку "False" всегда представляется нулем.

             if BoolValPassed <> False then DoSomething. 

Наверх к содержанию


Вопрос:
Как получить длинное имя файла или каталога, зная короткое имя?
Ответ:
Используйте Win32_Find_Data поле TSearchRec.
Пример
:

             procedure TForm1.Button1Click(Sender: TObject); 
             var 
               SearchRec : TSearchRec; 
               Success : integer; 
             begin 
               Success := SysUtils.FindFirst('C:\DownLoad\dial-u~1.htm', 
                                             faAnyFile, 
                                             SearchRec); 
               if Success = 0 then begin 
                 ShowMessage(SearchRec.FindData.CFileName); 
               end; 
               SysUtils.FindClose(SearchRec); 
             end; 

Наверх к содержанию


Вопрос:
Как временно отключить range checking для участка программы, а затем вновь вклчить его?
Ответ:
Можно сделать это, используя "IFOPT" и "DEFINE".

             type 
               PSomeArray = ^TSomeArray; 
               TSomeArray = array[0..0] of integer; 
 
             procedure TForm1.Button1Click(Sender: TObject); 
             var 
               p : PSomeArray; 
               i : integer; 
 
             begin 
             {$IFOPT R+} 
               {$DEFINE CKRANGE} 
               {$R-} 
             {$ENDIF} 
               GetMem(p, sizeof(integer) * 200); 
                  
               try 
                 for i := 1 to 200 do 
                   p[i] := i; 
               finally 
                 FreeMem(p, sizeof(integer) * 200); 
               end; 
 
             {$IFDEF CKRANGE} 
               {$UNDEF CKRANGE} 
               {$R+} 
             {$ENDIF} 
             end; 

Наверх к содержанию


Вопрос:
Как получить имя файла и путь локальной таблицы?
Ответ:
Следующий пример взят из файла BDE32.HLP Borland/CommonFiles/BDE directory:

 
             implementation 
 
             {$R *.DFM} 
 
             uses DbiTypes, DbiProcs; 
 
             function fDbiFormFullName(Tbl: TTable): String; 
             var 
               Props: CurProps; 
               Buffer1 : array[0..DBIMAXPATHLEN] of char; 
               Buffer2 : array[0..DBIMAXPATHLEN] of char; 
             begin 
               Check(DbiGetCursorProps(Tbl.Handle,Props)); 
               StrPCopy(Buffer1, Tbl.TableName); 
               Check(DbiFormFullName(Tbl.DBHandle, 
                                     @Buffer1, 
                                     Props.szTableType, 
                                     @Buffer2)); 
               Result := StrPas(Buffer2); 
             end; 
 
             procedure TForm1.Button1Click(Sender: TObject); 
             begin 
               Memo1.Lines.Add(fDbiFormFullName(Table1)); 
             end; 
 
             Примечание: 
               Таблица должна быть открытой.   
               Работает с локальными таблицами. 
 

Наверх к содержанию


Вопрос:
Как получить дескриптор панели задач (TaskBar)?
Ответ
:
hTaskbar := FindWindow('Shell_TrayWnd', Nil );
Наверх к содержанию


Вопрос:
Как из программы запустить Screen Saver?
Ответ:
Представленная ниже функция демонстрирует как это сделать

             function TurnScreenSaverOn : bool; 
             var 
               b : bool; 
             begin 
               result := false; 
               if SystemParametersInfo(SPI_GETSCREENSAVEACTIVE, 
                                       0, 
                                       @b, 
                                       0) <> true then exit; 
               if not b then exit; 
               PostMessage(GetDesktopWindow, WM_SYSCOMMAND, SC_SCREENSAVE, 0); 
               result := true; 
             end; 

Наверх к содержанию


Вопрос:
Как выяснить установлены ли в системе шрифты Tr
ueType?
Ответ:

             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 ); 

Наверх к содержанию