HARDWARE
Клавиатура
Каким узнать какая нажата кнопка на
клавиатуре (мыши) если активно другое окно?
Как программно переключать раскладку
клавиатуры?
Проверка нажатых функциональных клавиш
Определение нажатия
определенной клавиши во время загрузки
приложения.
Эмуляция нажатия клавиши с
кодом #255.
Эквивалент функции SendKeys Visual
Basic'а.
Включение/выключение
клавиатуры.
Мышь
Как программно эмулировать
движение мыши.
Есть ли у мыши колесико.
Включение/выключение мыши.
Монитор
Как узнать текущее и поменять
разрешение экрана?
Программное включение/
выключение монитора.
Модем
Как набрать номер с помощью
модема в Win32.
Опеределение состояния модема
под Win32.
Как
получить список установленных модемов в Win95/98?
Использование Tapi (Telephony API).
Прoцессор
Передача процессорных циклов
другим приложениям.
Увеличение процессорного
времени, выделяемого программе.
Как определить наличие
сопроцессора.
Диcк
Как узнать серийный номер
диска.
Серийный номер аудио CD.
Как узнать тип диска.
Форматирование диска.
Проверка готовности диска.
Есть ли в CD-ROM Audio CD.
Определение свободного
дискового пространства.
Как открыть и закрыть CD.
Принтер
Изменить порт принтера.
Программная установка драйвера
принтера.
Цветная печать.
Работа с принтером
Как
программно изменить количество копий выводимых
в печать?
PlugNPlay
Определить измения
оборудования PlugNPlay.
Динамик
Как выключить/включить PC Speaker?
Звуки из динамика.
Управление питанием ЭВМ из Delphi
Управление питанием ЭВМ из
Delphi
Видеокарта
Как
определить видеокарту
Каким образом можно узнать какая нажата кнопка
на клавиатуре (мыши) вне зависимости от того,
какое приложение в данный момент активно?
GetAsyncKeyState. И для клавиатуpы, и для
мыши.
Наверх к содержанию
Как выключить/включить PC Speaker?
Выключить:
SyStemParametersInfo(SPI_SETBEEP,0,nil,SPIF_UPDATEINIFILE);
Включить:
SyStemParametersInfo(SPI_SETBEEP,1,nil,SPIF_UPDATEINIFILE);
Наверх к содержанию
Как программно переключать раскладку
клавиатуры?
LoadKeyboardLayout('00000409', KLF_ACTIVATE); //
английский
LoadKeyboardLayout('00000419', KLF_ACTIVATE); // русский
Наверх к содержанию
Как узнать текущее разрешение экрана?
Screen.Width, Screen.Height Здесь Вы можете
посмотреть предложение из FIDO.RU о замене
разрешения экрана:
- procedure ChangeDisplayResolution(X, Y : Word);
- var
- Dm : TDEVMODE;
- begin
- ZeroMemory(@Dm, SizeOf(TDEVMODE));
- Dm.DmSize :=SizeOf(TDEVMODE);
- Dm.DmPelsWidth :=X;
- Dm.DmPelsHeight :=Y;
- Dm.DmFields :=DM_PELSWIDTH or DM_PELSHEIGHT;
- ChangeDisplaySettings(Dm, 0);
end;
Наверх к содержанию
4.Проверка нажатых функциональных клавиш
Функция GetKeyState (Win32API) возвращает статус кнопки
клавиатуры, переданной ей в качестве параметра.
Статус определяет, что кнопка нажата(down),
отпущена(up) или переключена(on/off, как например
клавиши NumLock или CapsLock). Если старший разряд
возвращаемого значения равен 1, то кнопка нажата,
иначе она отпущена. Если младший разряд равен 1,
то кнопка включена(состояние On), иначе кнопка
выключена(off).
SHORT GetKeyState( int nVirtKey );
Например:
IF GetKeyState(VK_NUMLOCK)=1 Then ...// Кнопка "NumLock" включена (on)
Вернуться к содержанию
Вопрос:
Как программно выключить монитор?
Ответ:
Программно можно отключить монитор совместимый
со стандартом 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;
Наверх к содержанию
Вопрос:
Форматирование диска в 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;
Наверх к содержанию
Вопрос:
Моя программа использует дравер принтера.
Возможно ли потихоньку установить драйвер
принтера без вмешательства пользователя?
Ответ:
Приведенный пример устанавливает драйвер
принтера. Вам необходимо скопировать файлы с
драйвером принтера в каталог 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.
Наверх к содержанию
Вопрос:
Как определение нажатия определенной клавиши во
время загрузки приложения?
Ответ:
Используйту WinAPI функцию GetKeyState() для определения
нажатия клавиши в тексте проекта. Для того чтобы
увидеть текст файла проекта в главном меню Delphi 3
выберите "View">>"ProjectSource" в Delphi 4
"Project">>"View Source".
Пример:
program Project1;
uses
Windows,
Forms,
Unit1 in 'Unit1.pas' {Form1};
{$R *.RES}
begin
if GetKeyState(vk_F8) < 1 then
MessageBox(0, 'F8 was pressed during startup', 'MyApp', mb_ok);
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.
Наверх к содержанию
Вопрос:
Как заставить пикнуть динамик несколько раз с
небольшой задержкой между сигналами, не
зависящей от тактовой частоты процессора?
Ответ:
См. пример.
Пример:
procedure Delay(ms : longint);
{$IFNDEF WIN32}
var
TheTime : LongInt;
{$ENDIF}
begin
{$IFDEF WIN32}
Sleep(ms);
{$ELSE}
TheTime :=GetTickCount + ms;
while GetTickCount < TheTime do
Application.ProcessMessages;
{$ENDIF}
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
MessageBeep(word(-1));
Delay(200);
MessageBeep(word(-1));
Delay(200);
MessageBeep(word(-1));
end;
Наверх к содержанию
Вопрос:
Можно ли отключить кнопку закрытия любого окна?
Ответ:
Да, приведенный пример отключает кнопку закрытия
и пункт "закрыть" ситсемного меню заданного
окна.
procedure TForm1.Button1Click(Sender: TObject);
var
hwndHandle : THANDLE;
hMenuHandle : HMENU;
begin
hwndHandle :=FindWindow(nil, 'Untitled - Notepad');
if (hwndHandle <> 0) then begin
hMenuHandle :=GetSystemMenu(hwndHandle, FALSE);
if (hMenuHandle <> 0) then
DeleteMenu(hMenuHandle, SC_CLOSE, MF_BYCOMMAND);
end;
end;
Наверх к содержанию
Вопрос:
Как определить имена установленых 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;
Наверх к содержанию
Вопрос:
Как уступить выделенный моей программе квант
процессорного времени другим приложениям?
Ответ:
Вызовите функцию Windows API Sleep() передав ноль в
качестве параметра.
Наверх к содержанию
Вопрос:
Как увеличить процессорное время, выделяемого
программе?
Ответ:
Следующий пример изменяет приоритет приложения.
Изменение приоритета следует использовать с
осторожностью - т.к. присвоение слишком высокого
приоритета может привети к медленной работе
остальных программ и системы в целом. См. 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;
Наверх к содержанию
Вопрос:
Как опеределить состояние модема под 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;
Наверх к содержанию
Вопрос:
Как узнать серийный номер диска
Ответ:
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;
Наверх к содержанию
Вопрос:
Для закрытия CD-ROM:
--------------------------------------------------------------------------------
mciSendString('Set cdaudio door open wait', nil, 0, handle);
Для открытия CD-ROM:
--------------------------------------------------------------------------------
mciSendString('Set cdaudio door closed wait', nil, 0, handle);
Не забудьте включить MMSystem в список используемых модулей (uses).
Наверх к содержанию
Вопрос:
Как определить свободное дисковое пространство
на дисках размером больше 2 ГБ?
Ответ:
Вызовите функцию GetDiskFreeSpaceEx(). Возвращаемый
функцией результат типа integers конвертируйте в
doubles.
Пример:
function GetDiskFreeSpaceEx(lpDirectoryName: PAnsiChar;
i lpFreeBytesAvailableToCaller : Integer;
i lpTotalNumberOfBytes: Integer;
i lpTotalNumberOfFreeBytes: Integer) : bool;
stdcall;
external kernel32
name 'GetDiskFreeSpaceExA';
procedure GetDiskSizeAvail(TheDrive : PChar;
i TotalBytes : double;
i 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;
Наверх к содержанию
Вопрос:
Как программно изменить текущий порт принтера?
Ответ:
Используйте метод 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;
Наверх к содержанию
Вопрос:
Как печатать в цвете?
Ответ:
Обычно нет необходимости переводить принтер в
режим цветной печати, если он установлен в этот
режим. 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;
Наверх к содержанию
Вопрос:
Как определить наличие сопроцессора?
Ответ:
В отличие от общепринятого мнения не всее клоны 486/586/686/ и Pentium
имеют сопроцессор для вычислений с плавающей запятой. В примере определяется
наличие сопроцессора и под Win16 и под Win32.
Пример:
{$IFDEF WIN32}
uses Registry;
{$ENDIF}
function HasCoProcesser : bool;
{$IFDEF WIN32}
i
TheKey : hKey;
{$ENDIF}
begin
Result :=true;
{$IFNDEF WIN32}
if GetWinFlags and Wf_80x87=0 then
Result :=false;
{$ELSE}
if RegOpenKeyEx(HKEY_LOCAL_MACHINE,
'HARDWARE\DESCRIPTION\System\FloatingPointProcessor',0,
KEY_EXECUTE, TheKey) <> ERROR_SUCCESS then result :=false;
RegCloseKey(TheKey);
{$ENDIF}
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if HasCoProcesser then
ShowMessage('Has CoProcessor')
else
ShowMessage('No CoProcessor - Windows Emulation Mode');
end;
Наверх к содержанию
Вопрос:
Как узнать серийный номер аудио CD?
Ответ:
CD может иметь или не иметь серийный номер и/или универсальный код продукта
(Universal Product Code). MCI-расширение Windows предоставляет эту информации
с помощью комманды MCI_INFO_MEDIA_IDENTITY command. Эта команда возвращает
уникальную ID-строку.
Пример:
uses MMSystem, MPlayer;
procedure TForm1.Button1Click(Sender: TObject);
i
mp : TMediaPlayer;
msp : TMCI_INFO_PARMS;
MediaString : array[0..255] of char;
ret : longint;
begin
mp :=TMediaPlayer.Create(nil);
mp.Visible :=false;
mp.Parent :=Application.MainForm;
mp.Shareable :=true;
mp.DeviceType :=dtCDAudio;
mp.FileName :='D:';
mp.Open;
Application.ProcessMessages;
FillChar(MediaString, sizeof(MediaString), #0);
FillChar(msp, sizeof(msp), #0);
msp.lpstrReturn :=@MediaString;
msp.dwRetSize :=255;
ret :=mciSendCommand(Mp.DeviceId, MCI_INFO, MCI_INFO_MEDIA_IDENTITY,
longint(@msp));
if Ret <> 0 then
begin
MciGetErrorString(ret, @MediaString, sizeof(MediaString));
Memo1.Lines.Add(StrPas(MediaString));
end
else
Memo1.Lines.Add(StrPas(MediaString));
mp.Close;
Application.ProcessMessages;
mp.free;
end;
end.
Наверх к содержанию
Вопрос:
Как узнать есть ли в заданном CD-ROM'е Audio CD?
Ответ:
Можно использовать функцию Windows API GetDriveType() чтобы определить
является ли дисковод CD-ROM'мом. И функцию API GetVolumeInformation() чтобы
проверить VolumeName на равенство 'Audio CD'.
Пример:
function IsAudioCD(Drive : char) : bool;
i
DrivePath : string;
MaximumComponentLength : DWORD;
FileSystemFlags : DWORD;
VolumeName : string;
Begin
sult :=false;
DrivePath :=Drive + ':\';
if GetDriveType(PChar(DrivePath)) <> DRIVE_CDROM then
exit;
SetLength(VolumeName, 64);
GetVolumeInformation(PChar(DrivePath),PChar(VolumeName),
Length(VolumeName),nil,MaximumComponentLength,FileSystemFlags,nil,0);
if lStrCmp(PChar(VolumeName),'Audio CD')=0 then
result :=true;
end;
function PlayAudioCD(Drive : char) : bool;
i
mp : TMediaPlayer;
begin
result :=false;
Application.ProcessMessages;
if not IsAudioCD(Drive) then
exit;
mp :=TMediaPlayer.Create(nil);
mp.Visible :=false;
mp.Parent :=Application.MainForm;
mp.Shareable :=true;
mp.DeviceType :=dtCDAudio;
mp.FileName :=Drive + ':';
mp.Shareable :=true;
mp.Open;
Application.ProcessMessages;
mp.Play;
Application.ProcessMessages;
mp.Close;
Application.ProcessMessages;
mp.free;
result :=true;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if not PlayAudioCD('D') then
ShowMessage('Not an Audio CD');
end;
Наверх к содержанию
Вопрос:
Как узнать есть ли у мыши колесико?
Ответ:
Свойство "WheelPresent" глобального обьекта
"mouse".
Наверх к содержанию
Вопрос:
Функция keybd_event() принимает значения до 244 - как мне отправить
нажатие
клавиши с кодом #255 в элемент управления Windows?
Ответ:
Это может понадобится для иностранных языков или
для специальных символов. (например,
в русских шрифтах символ с кодом #255 - я прописное).
Приведенный в примере метод,
не стоит использовать в случае если символ может
быть передан обычным способом
(функцией keybd_event()).
procedure TForm1.Button1Click(Sender: TObject);
i
KeyData : packed record
RepeatCount : word;
ScanCode : byte;
Bits : byte;
end;
begin
{Let the button repaint}
Application.ProcessMessages;
{Set the focus to the window}
Edit1.SetFocus;
{Send a right so the char is added to the end of the line}
// SimulateKeyStroke(VK_RIGHT, 0);
keybd_event(VK_RIGHT, 0,0,0);
{Let the app get the message}
Application.ProcessMessages;
FillChar(KeyData, sizeof(KeyData), #0);
KeyData.ScanCode :=255;
KeyData.RepeatCount :=1;
SendMessage(Edit1.Handle, WM_KEYDOWN, 255,LongInt(KeyData));
KeyData.Bits :=KeyData.Bits or (1 shl 30);
KeyData.Bits :=KeyData.Bits or (1 shl 31);
SendMessage(Edit1.Handle, WM_KEYUP, 255, LongInt(KeyData));
KeyData.Bits :=KeyData.Bits and not (1 shl 30);
KeyData.Bits :=KeyData.Bits and not (1 shl 31);
SendMessage(Edit1.Handle, WM_CHAR, 255, LongInt(KeyData));
Application.ProcessMessages;
end;
Наверх к содержанию
Вопрос:
Некоторые компоненты не меняют курсор мыши до тех пор пока пользователь
не
сдвинет мышь. Как эмулировать движение мыши?
Ответ:
В примере мышка слегка "подталкивается" без
участия пользователя.
procedure TForm1.Button1Click(Sender: TObject);
i
pt : TPoint;
begin
Application.ProcessMessages;
Screen.Cursor :=CrHourglass;
GetCursorPos(pt);
SetCursorPos(pt.x + 1, pt.y + 1);
Application.ProcessMessages;
SetCursorPos(pt.x - 1, pt.y - 1);
end;
Наверх к содержанию
Есть ли в Delphi эквивалент функции SendKeys Visual Basic'а?
Ответ:
Ниже приведена процедура, позволяющаю отправлять нажатия в любой элемент
управления (window control), способный принимать ввод с клавиатуры. Вы
можете использовать эту технику чтобы включать клавиши NumLock, CapsLock
и ScrollLock под Windows NT. Та же техника работает и под Windows 95 для
CapsLock и ScrollLock но не работает для клавиши NumLock.
Обратите внимание, что приведены четыре поцедуры: SimulateKeyDown()
- эмулировать нажатие клавиши (без отпускания) SimulateKeyUp() - эмулировать
отпускание клавиши SimulateKeystroke() - эмулировать удар по клавише (нажатие
и отпускание) и SendKeys(), позволяющие Вам гибко контролировать посылаемые
сообщения клавиатуры.
SimulateKeyDown(), SimulateKeyUp() и SimulateKeystroke() получают коды
виртуальных клавиш (virtural key) (вроде VK_F1). Процедура SimulateKeystroke()
получает дополнительный параметр, полезный при эмуляции нажатия PrintScreen.
Когда этот параметр равен нулю весь экран будет скопирован в буфер обмена
(clipboard). Если дополнительный параметр равен 1 будет скопированно только
активное окно.
Четыре метода "button click" демонстрируют использование: ButtonClick1
- включает capslock ButtonClick2 - перехватывает весь экран в буфер обмена
(clipboard). ButtonClick3 - перехватывает активное окно в буфер обмена
(clipboard). ButtonClick4 - устанавливает фокус в Edit и отправляет в него
строку.
Пример:
procedure SimulateKeyDown(Key : byte);
begin
keybd_event(Key, 0, 0, 0);
end;
procedure SimulateKeyUp(Key : byte);
begin
keybd_event(Key, 0, KEYEVENTF_KEYUP, 0);
end;
procedure SimulateKeystroke(Key : byte; extra : DWORD);
begin
keybd_event(Key,extra,0,0);
keybd_event(Key,extra,KEYEVENTF_KEYUP,0);
end;
procedure SendKeys(s : string);
i
i : integer;
flag : bool;
w : word;
begin
{Get the state of the caps lock key}
flag :=not GetKeyState(VK_CAPITAL) and 1=0;
{If the caps lock key is on then turn it off}
if flag then
SimulateKeystroke(VK_CAPITAL, 0);
for i :=1 to Length(s) do
begin
w :=VkKeyScan(s[i]);
{If there is not an error in the key translation}
if ((HiByte(w) <> $FF) and (LoByte(w) <> $FF)) then
begin
{If the key requires the shift key down - hold it down}
if HiByte(w) and 1=1 then
SimulateKeyDown(VK_SHIFT);
{Send the VK_KEY}
SimulateKeystroke(LoByte(w), 0);
{If the key required the shift key down - release it}
if HiByte(w) and 1=1 then
SimulateKeyUp(VK_SHIFT);
end;
end;
{if the caps lock key was on at start, turn it back on}
if flag then
SimulateKeystroke(VK_CAPITAL, 0);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
{Toggle the cap lock}
SimulateKeystroke(VK_CAPITAL, 0);
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
{Capture the entire screen to the clipboard}
{by simulating pressing the PrintScreen key}
SimulateKeystroke(VK_SNAPSHOT, 0);
end;
procedure TForm1.Button3Click(Sender: TObject);
begin
{Capture the active window to the clipboard}
{by simulating pressing the PrintScreen key}
SimulateKeystroke(VK_SNAPSHOT, 1);
end;
procedure TForm1.Button4Click(Sender: TObject);
begin
{Set the focus to a window (edit control) and send it a string}
Application.ProcessMessages;
Edit1.SetFocus;
SendKeys('Delphi Is RAD!');
end;
Наверх к содержанию
Как получить список
модемов
Stas Malinovski 3.1.1999
Предлагаю следующий модуль для этих целей:
unit PortInfo;
interface
uses
Windows, SysUtils, Classes, Registry;
function EnumModems : TStrings;
implementation
function EnumModems : TStrings;
var
R : TRegistry;
S : ShortString;
N : TStringList;
I : Integer;
J : Integer;
begin
Result :=TStringList.Create;
R :=TRegistry.Create;
try
with R do
begin
RootKey :=HKEY_LOCAL_MACHINE;
if OpenKey('\System\CurrentControlSet\Services\Class\Modem',
False)
then
if HasSubKeys then
begin
N :=TStringList.Create;
try
GetKeyNames(N);
for I :=0to N.Count - 1do
begin
OpenKey(N[I], False);
S :=ReadString('AttachedTo');
for J :=1to4do
if Pos(Chr(J + Ord('0')), S) > 0then Break;
Result.AddObject(ReadString('DriverDesc'),
TObject(J));
CloseKey;
end;
finally
N.Free;
end;
end;
end;
finally
R.Free;
end;
end;
end.
Работа с принтером.
Delphi имеет стандартный объект для доступа к принтеру - TPRINTER,
находящийся в модуле PRINTERS. В этом модуле имеется переменная Printer:Tpinter,
что избавляет от необходимости описывать свою. Он позволяет выводить данные
на печать и управлять процессом печати. Правда, в некоторых версиях Delphi
1 он имеет "глюк" - не работают функции Draw и StrethDraw. Но эта проблема
поправима - можно использовать функции API. Далее приведены основные поля
и методы объекта Printers :
PROPERTY
Aborted:boolean - Показывает, что процесс печати прерван
Canvas:Tcanvas - Стандартный Canvas, как у любого графического объекта.
Он позволяет рисовать на листе бумаге графику, выводить текст ... . Тут
есть несколько особенностей, они описаны после описания объекта.
Fonts:Tstrings - Возвращает список шрифтов, поддерживаемых принтером
Handle:HDS - Получить Handle на принтер для использования функций API
(см. Далее)
Orientation:TprinterOrientation - Ориентация листа при печати : (poPortrait,
poLandscape)
PageHeight:integer - Высота листа в пикселах
PageNumber:integer - Номер страницы, увеличивается на 1 при каждом
NewPage
PageWidth:integer - Ширина листа в пикселах
PrinterIndex:integer - Номер используемого принтера по списку доступных
принтеров Printers
Printers:Tstrings - Список доступных принтеров
Printing:boolean - Флаг, показывающий, что сейчас идет процесс печати
Title:string - Имя документа или приложения. Под этим именем задание
на печать регистрируется в диспетчере печати
METODS
AssignPrn(f:TextFile) - Связать текстовый файл с принтером. Далее вывод
информации в этот файл приводит к ее печати. Удобно в простейших случаях.
Abort - Сбросить печать
BeginDoc - Начать печать
NewPage - Начать новую страницу
EndDoc - Завершить печать.
Пример :
Procedure TForm1.Button1Click(Sender: TObject);
Begin
With Printer do Begin
BeginDoc; { Начало печати }
Canvas.Font:=label1.font; { Задали шрифт }
Canvas.TextOut(100,100,'Это тест принтера !!!'); { Печатаем текст }
EndDoc; { Конец печати }
end;
end;
Особенности работы с TPrinter
1. После команды BeginDoc шрифт у Canvas принтера сбрасывается и его
необходимо задавать заново
2. Все координаты даны в пикселах, а для нормальной работы необходимы
миллиметры (по двум очевидным причинам: очень трудно произвести разметку
страницы в пикселах (особенно если необходима точность), и , главное, при
изменении разрешающей способности принтера будет изменяться число точек
на дюйм, и все координаты "поедут".
3. У TPrinter информация о принтере, по видимому, определяются один
раз - в момент запуска программы (или смены принтера). Поэтому изменение
настроек принтера в процессе работы программы может привести к некорректной
работе, например, неправильной печать шрифтов True Type.
Определение параметров принтера через API
Для определения информации о принтере (плоттере, экране) необходимо
знать Handle этого принтера, а его можно узнать объекта TPrinter - Printer.Handle.
Далее вызывается функция API (unit WinProcs) : GetDevice(Handle:HDC; Index:integer):integer;
Index - код параметра, который необходимо вернуть. Для Index существует
ряд констант :
DriverVersion - вернуть версию драйвера
Texnology - Технология вывода, их много, основные
dt_Plotter - плоттер
dt_RasPrinter - растровый принтер
dt_Display - дисплей
HorzSize - Горизонтальный размер листа (в мм)
VertSize - Вертикальный размер листа (в мм)
HorzRes - Горизонтальный размер листа (в пикселах)
VertRes - Вертикальный размер листа (в пикселах)
LogPixelX - Разрешение по оси Х в dpi (пиксел /дюйм)
LogPixelY - Разрешение по оси Y в dpi (пиксел /дюйм)
Кроме перечисленных еще около сотни, они позволяют узнать о принтере
практически все.
Параметры, возвращаемые по LogPixelX и LogPixelY очень важны - они
позволяют произвести пересчет координат из миллиметров в пиксели для текущего
разрешения принтера. Пример таких функций:
Procedure TForm1.GetPrinterInfo; { Получить информацию о принтере }
begin
PixelsX:=GetDeviceCaps(printer.Handle,LogPixelsX);
PixelsY:=GetDeviceCaps(printer.Handle,LogPixelsY);
end;
Function TForm1.PrinterCoordX(x:integer):integer; { переводит координаты из мм в пиксели }
begin
PrinterCoordX:=round(PixelsX/25.4*x);
end;
Function TForm1.PrinterCoordY(Y:integer):integer; { переводит координаты из мм в пиксели }
begin
PrinterCoordY:=round(PixelsY/25.4*Y);
end;
---------------------------------
GetPrinterInfo;
Printer.Canvas.TextOut(PrinterCoordX(30), PrinterCoordY(55),
'Этот текст печатается с отступом 30 мм от левого края и '+
'55 мм от верха при любом разрешении принтера');
Данную методику можно с успехом применять для печати картинок - зная размер
картинки можно пересчитать ее размеры в пикселах для текущего разрешения
принтера, масштабировать, и затем уже распечатать. Иначе на матричном принтере
(180 dpi) картинка будет огромной, а на качественном струйнике (720 dpi)
- микроскопической.
Иногда может возникнуть необходимость
в выключении на время устройств ввода -
клавиатуры и мыши. Например, это неплохо сделать
на время выполнения кода системы защиты от
копирования, в играх, или в качестве
"наказания" при запуске программы по
истечению срока ее бесплатного использования ... .
Однако наилучшее ее применение - отключение
клавиатуры и мыши на время работы
демонстрационки, основанной на воспроизведении
записанных заранее перемещений мышки и
клавиатурного ввода (см. об этом отдельный раздел
этой книги). Это элементарно сделать при помощи
API:
EnableHadwareInput(Enable:boolean): boolean; Enable - требуемое
состояние устройств ввода (True - включены, false -
выключены). Если ввод заблокирован, то его можно
разблокировать вручную - нажать Ctrl + Alt + Del, при
появлении меню "Завершение работы
программы" ввод разблокируется.
Наверх
Управление питанием из программы
на Delphi
При написании разнообразны программ типа заставок, менеджеров управления
компьютером ... возникает необходимость переводить компьютер в режим "спячки".
Для включения этого режима в Windows 95 (и только в ней !!) предусмотрена
команда API:
SetSystemPowerState(Suspended, Mode: Boolean):boolean;
Suspended должно быть TRUE для ухода в спячку.
Mode - режим входа в спячку. Если TRUE, то всем программам и драйверам
посылается Message PBT_APMSUSPEND, по которому они должны немедленно прекратить
работу. Если FALSE, то посылается Message PBT_APMQUERYSUSPEND запроса на
спячку, и драйвера в ответ могут дать отказ на включение режима спячки.
Возврат функции SetSystemPowerState: TRUE - режим включен.
Ivanuts V.A.
31.10.2001
Если эта задача стоит в процессе вывода на
печать документов из QuickReport, то достаточно
изменить значение свойства PrinterSettings.Copies,
например:
procedure TMyForm.PrintBtnClick(Sender : TObject);
begin QuickReport1.PrinterSettings.Copies :=StrToInt(Edit1.Text);
end;
Если же печать документа производится путем
функциональных возможностей модуля Printers, то
необходимо организовать цикл повторения печати,
например:
- procedure TMyForm.PrintBtnClick(Sender : TObject);
- var
- I : Integer;
- begin
- for I :=0to
StrToInt(Edit1.Text) do
- begin
- Printer.BeginDoc;
- . . .
- Printer.EndDoc;
- end;
- end;
Как определить видеокарту
Первая форма имеет кнопку. Создайте другую форму
с memo
//=======================================================
procedure TForm1.button1click(Sender: TObject);
i
lpDisplayDevice: TDisplayDevice;
dwFlags: DWORD;
cc: DWORD;
begin
form2.memo1.Clear;
lpDisplayDevice.cb :=sizeof(lpDisplayDevice);
dwFlags :=0;
cc:=0;
while EnumDisplayDevices(nil, cc, lpDisplayDevice , dwFlags) do
begin
Inc(cc);
form2.memo1.lines.add(lpDisplayDevice.DeviceString);
{Так же мы увидим дополнительную информацию в
lpDisplayDevice}
form2.show;
end;
end;
|