Sprzęt i peryferia w Delphi

1.   Wciśnięcie dowolnego klawisza klawiatury z poziomu programu

keybd_event(Ord(Chr(32)),0,0,0);
keybd_event(Ord(Chr(32)),0,KEYEVENTF_KEYUP,0);

//uwaga: numer klawisza (w przykładzie 32 oznacza spację) sprawdzić można wywołując procedurę OnKeyDown dla Memo:
procedure TForm1.Memo1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
ShowMessage(IntToStr(Key));
end;

2.   Reakcja po wciśnięciu określonego klawisza na klawiaturze

var MainHook: hHook;

function KeyHook(code: Integer; wPar : wParam; lPar : lParam): Longint; StdCall;
var kState: TKeyboardState;
begin
GetKeyboardState(kState);   if (kState[32] and $80) < > 0
then ShowMessage('Wcisnąłeś spację');
if (kState[65] and kState[66] and not kState[67] and $80) < > 0
then ShowMessage('Wcisnąłeś jednocześnie klawisze A i B przy czym klawisz C nie był wciśnięty');
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
MainHook:=SetWindowsHookEx(WH_Keyboard,KeyHook,hInstance,0);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
UnhookWindowsHookEx(MainHook);
end;

//uwaga: numer klawisza (w przykładzie 32 oznacza spację) sprawdzić można wywołując procedurę OnKeyDown dla Memo:
procedure TForm1.Memo1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
ShowMessage(IntToStr(Key));
end;

3.   Nadpisanie instrukcji wykonywanej przez system po wciśnięciu określonego klawisza na klawiaturze

private
procedure WMHotKey(var Msg : TMessage); message WM_HOTKEY;

procedure TForm1.FormCreate(Sender: TObject);
begin
RegisterHotKey(Handle,$0001,0,VK_SPACE);   //Space
RegisterHotKey(Handle,$0002,MOD_ALT,VK_A);   //Alt+A=ą
RegisterHotKey(Handle,$0003,MOD_SHIFT,VK_0);  //Shift+2=@
RegisterHotKey(Handle,$0004,0,VK_F12);  //F12
end;

procedure TForm1.WMHotKey(var Msg: TMessage);
begin
if Msg.wParam=$0001 then ShowMessage('Wybrano spację');
if Msg.wParam=$0002 then ShowMessage('Wybrano literę ą');
if Msg.wParam=$0003 then ShowMessage('Wybrano znak @');
if Msg.wParam=$0004 then ShowMessage('Wybrano F12');
end;

//uwaga: 1.  reakcja domyślna (na przykład zrobienie odstepu dla kalwisza Space) po nadpisaniu nie zostanie wywołana
2.   niemożliwe jest nadpisanie tą metodą zdarzenia wywołango dla kombinacji kalwiszy Alt+Ctrl+Del

4.   Blokada klawisza PrintScreen

private
procedure WMHotKey(var Msg : TMessage); message WM_HOTKEY;

procedure TForm1.FormCreate(Sender: TObject);
begin
RegisterHotKey(Handle,$0001,0,VK_SNAPSHOT);
end;

procedure TForm1.WMHotKey(var Msg: TMessage);
begin
if Msg.wParam=$0001 then begin
//tu można wpisać instrukcję wykonywaną po wciśnięciu klawisza PrintScreen
end; end;

5.   Sprawdzanie ścieżki katalogu w którym zainstalowany został Windows

function TForm1.GdzieWindows: String;
var wDir: array [0..255] of Char;
begin
GetWindowsDirectory(wDir,SizeOf(wDir));
Result:=wDir;
end;

6.   Sprawdzanie ścieżki katalogu systemowego

function TForm1.GdzieSystem: String;
var wDir: array [0..255] of Char;
begin
GetSystemDirectory(wDir,SizeOf(wDir));   Result:=wDir;
end;

7.   W jaki sposób zasymulować kliknięcie myszy lub klawiatury, ale w taki sposób, żeby było wykrywalne przez inne programy

Do symulacji kliknięć mysz± służy funkcja WinAPI mouse_event:
SetCursorPos(x, y); // przedtem dane (ustawienie) dla kursora - pozycja x,y mouse_event(MOUSEEVENTF_ABSOLUTE or MOUSEEVENTF_LEFTDOWN, x, y, 0, 0);
mouse_event(MOUSEEVENTF_ABSOLUTE or MOUSEEVENTF_LEFTUP, x, y, 0, 0);
co daje symulację kliknięcia lewym przyciskiem myszy w punkcie (x,y), natomiast do symulacji klawiatury używamy funkcji keybd_event:
keybd_event(VK_UP, 0, 0, 0);
keybd_event(VK_UP, 0, KEYEVENTF_KEYUP, 0);
Co powoduje symulację kliknięcia klawisza strzałki w górę.

8.   Numer dysku - Disk Serial Numbers

unit Sernumu;

interface

uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls;

type TMediaID = Record
InfoLevel : Word;   SerialNumber : LongInt;
VolumeLabel : Array[0..10] of Char; SysName : Array[0..7] of Char;
End;
TForm1 = class(TForm) Button1: TButton;   Label1: TLabel;
Label2: TLabel;   Label3: TLabel;
procedure Button1Click(Sender: TObject);
private   { Private declarations }
MediaID : TMediaID;
public   { Public declarations }
end;

var Form1: TForm1;

implementation {$R *.DFM}

type DPMIRegisters = record
DI : LongInt; SI : LongInt; BP : LongInt; Reserved : LongInt;
BX : LongInt; DX : LongInt; CX : LongInt; AX : LongInt;
Flags : Word; ES : Word; DS : Word; FS : Word; GS : Word;
IP : Word; CS : Word; SP : Word; SS : Word;
end;

function RealIntr(IntNo : Byte; var Regs : DPMIRegisters) : Word; Assembler;
asm
xor bx,bx
mov bl,IntNo
xor cx,cx {StackWords = 0}
les di,Regs
mov ax,0300h
int 31h
jc @@ExitPoint
xor ax,ax
@@ExitPoint:
end;

function GetDiskInfo(Drive : Word; var MediaID : TMediaID) : Boolean;
type tLong = Record LoWord, HiWord : Word;
End;
var Regs : DPMIRegisters; dwAddress : LongInt; Address : tLong absolute dwAddress;
begin
Result := False;   FillChar(MediaID, SizeOf(MediaID), 0);
dwAddress := GlobalDosAlloc(SizeOf(MediaID));   { two paragraphs of DOS memory }
if dwAddress = 0 then   { address is zero if error occurred }
exit;

With Regs do begin
bx := Drive;
cx := $66;
ds := Address.HiWord;
ax := $6900;
dx := 0;
es := 0;
flags := 0;
end;
If RealIntr($21, Regs) < > 0 Then   Exit;
Move(ptr(Address.LoWord, 0)^, MediaID, SizeOf(MediaID));
GlobalDosFree(Address.LoWord)   { free DOS memory block }
Result := True;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
GetDiskInfo(1, MediaID);   With MediaID do Begin
Label1.Caption := IntToHex(SerialNumber, 8);
Label2.Caption := VolumeLabel;   Label3.Caption := SysName;   End;
end;

end.

9.   Odczyt (informacja) o dysku

type
MIDPtr = ^MIDRec; MIDRec = Record InfoLevel: word; SerialNum: LongInt;
VolLabel: Packed Array [0..10] of Char;
FileSysType: Packed Array [0..7] of Char;
end;

function GetDriveSerialNum(MID: MIDPtr; drive: Word): Boolean; assembler;
asm
push DS   { Just for safety, I dont think its really needed }
mov ax,440Dh   { Function Get Media ID }
mov bx,drive   { drive no (0-Default, 1-A ...) }
mov cx,0866h   { category and minor code }
lds dx,MID   { Load pointeraddr. }
call DOS3Call   { Supposed to be faster than INT 21H }
jc @@err
mov al,1   { No carry so return TRUE }
jmp @@ok
@@err:
mov al,0 { Carry set so return FALSE }
@@ok:
pop DS   { Restore DS, were not supposed to change it }
end;

procedure TForm1.NrBtnClick(Sender: TObject);
var Info: MIDRec;
begin
Info.InfoLevel:=0;   { Information Level }
If GetDriveSerialNum(@Info,0) then   { Do something with it... }
ListBox.Items.Add(IntToStr(Info.SerialNum)+' '+Info.VolLabel);
end;

10.   Odczyt numeru seryjnego dysku twardego

function GetHardDiskSerial(const DriveLetter: Char): string;
var NotUsed: DWORD; VolumeFlags: DWORD;
VolumeInfo: array[0..MAX_PATH] of Char;
VolumeSerialNumber: DWORD;
begin
GetVolumeInformation(PChar(DriveLetter + ':\'), nil, SizeOf(VolumeInfo), @VolumeSerialNumber, NotUsed, VolumeFlags, nil, 0);
Result := Format('Label = %s VolSer = %8.8X', [VolumeInfo, VolumeSerialNumber])
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage(GetHardDiskSerial('c'));
end;

11.   Odczyt / ustawienie nazwy komputera

function GetComputerName: string;
var buffer: array[0..MAX_COMPUTERNAME_LENGTH + 1] of Char; Size: Cardinal;
begin
Size := MAX_COMPUTERNAME_LENGTH + 1;
Windows.GetComputerName(@buffer, Size);
Result := StrPas(buffer);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage(GetComputerName);
end;

//ustawienie nazwy komputera...
function SetComputerName(AComputerName: string): Boolean;
var ComputerName: array[0..MAX_COMPUTERNAME_LENGTH + 1] of Char; Size: Cardinal;
begin
StrPCopy(ComputerName, AComputerName);
Result := Windows.SetComputerName(ComputerName);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
if SetComputerName('NewComputerName') then
ShowMessage('Computer Name Reset Setting will be used at next startup.')
else   ShowMessage('Computer Name Not Reset');
end;

12.   Odczyt globalnej i dostępnej pamięci

procedure TForm1.Button1Click(Sender: TObject);
var memory: TMemoryStatus;
begin
memory.dwLength := SizeOf(memory);   GlobalMemoryStatus(memory);
ShowMessage('Total Arbeitsspeicher/Total memory: ' +
IntToStr(memory.dwTotalPhys) + ' Bytes');
ShowMessage('Freier Arbeitsspeicher/Available memory: ' +
IntToStr(memory.dwAvailPhys) + ' Bytes');
end;

13.   Odczyt ustawień drukarki

Oczywiście - drukarka musi byc włączona

var FDevice: PChar; FDriver: PChar; FPort: PChar;
DeviceMode: THandle; DevMode: PDeviceMode;

procedure OpenThePrinterDevice;
var Driver_Info2: PDriverInfo2; Retrieved: dword; hPrinter: THandle;
begin
Printer().GetPrinter(FDevice, FDriver, FPort, DeviceMode);
if DeviceMode = 0 then
Printer().GetPrinter(FDevice, FDriver, FPort, DeviceMode);   OpenPrinter(FDevice, hPrinter, nil);
GetMem(Driver_Info2, 255);
GetPrinterDriver(hPrinter, nil, 2, Driver_info_2, 255, Retrieved);
StrLCopy(FDriver, PChar(ExtractFileName(StrPas(Driver_Info2^.PDriverPath)) + #0), 63);
FreeMem(Driver_info_2, 255);   DevMode := GlobalLock(DeviceMode);
end;

14.   Jak sprawdzic czy klawisze Num Lock, Caps Lock, Scroll Lock, Insert są włączone?

function IsKeyToggled( VirtKey: Integer): Boolean;
begin
Result := (GetKeyState( VirtKey ) and $0001) < > 0;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
chkCaps.Checked := IsKeyToggled( VK_CAPITAL );
chkNum.Checked := IsKeyToggled( VK_NUMLOCK );
chkScroll.Checked := IsKeyToggled( VK_SCROLL );
chkIns.Checked := IsKeyToggled( VK_INSERT );
end;

15.   Jak otworzyć i zamknąć naped CDROM o dowolnej literze?

Ponizsza procedura otwiera/zamyka szuflade napedu CD w oparciu o podane parametry, co pozwala na wybranie napedu jesli sa dwa lub wiecej w danym komputerze.

uses MMSystem;

procedure OpenCloseCD(Drive: String; OpenCD: Boolean);
var OpenParm: TMCI_Open_Parms;
begin
OpenParm.dwCallback := 0;   OpenParm.lpstrDeviceType := 'CDAudio';
OpenParm.lpstrElementName := PChar(Drive);   {Drive musi byc w formacie "X:"}
if OpenCD then begin   {Otwieranie szuflady}
mciSendCommand(0, MCI_OPEN, MCI_OPEN_ELEMENT or MCI_OPEN_TYPE, Longint(@OpenParm));
mciSendCommand(OpenParm.wDeviceID, MCI_SET, MCI_SET_DOOR_OPEN, 0);
end else begin   {zamykanie szuflady}
mciSendCommand(0, MCI_OPEN, MCI_OPEN_ELEMENT or MCI_OPEN_TYPE, Longint(@OpenParm));
mciSendCommand(OpenParm.wDeviceID, MCI_SET, MCI_SET_DOOR_CLOSED, 0);
end;   {zamykanie MCI, bez tego kolejna proba otwarcia/zamkniecia szuflady zakonczylaby sie niepowodzeniem!!! }
mciSendCommand(OpenParm.wDeviceID, MCI_CLOSE, MCI_NOTIFY, Longint(@OpenParm));
OpenCD := not OpenCD;
end;

16.   Jak wykryć czy w komputerze jest zainstalowana karta muzyczna?

Po pierwsze musisz dodać do listy uses nazwę modułu MMSystem i należy użyć funkcji WaveOutGetNumDevs

if WaveOutGetNumDevs > 0 then
Label1.Caption := 'Jest karta dźwiękowa!'
else   Label1.Caption := 'Brak karty dźwiękowej!';

17.   Jak sprawdzić jaka jest pojemność dysku i ile jest wolnego miejsca?

Do podawania wolnej ilości na dysku służy funkcja DiskFree, a do podawania całego rozmiaru służy DiskSize.

begin
Label1.Caption := Format('Wolne miejsce: %d',[DiskFree(0)]);
Label2.Caption := Format('Całe miejsce: %d', [DiskSize(0)]);
end;

18.   Jak zmienić tapetę pulpitu?

var S : String;
begin
S := 'zdjecie.bmp';
SystemParametersInfo(SPI_SETDESKWALLPAPER,0, PChar(s),
SPIF_UPDATEINIFILE or SPIF_SENDWININICHANGE);
end;

19.   Jak programowo włączyć lub wyłączyć monitor?

Należy wysłać komunikat wm_SysCommand z parametrem wParam ustawionym na SC_MonitorPower zaś lParam ustawionym na:
0 - aby wyłączyć monitor
1 - aby go włączyć z powrotem

// Wyłączenie monitora:
SendMessage(Application.Handle,wm_SysCommand,SC_MonitorPower,0);

// Włączenie monitora.................
SendMessage(Application.Handle,wm_SysCommand,SC_MonitorPower, 1);

// Uśpienie komputera...............
SendMessage(Application.Handle,wm_SysCommand,SC_SCREENSAVE,-1);

20.   Jak uniemożliwić uruchomienie wygaszacza ekranu?

//włączenie blokady......
SystemParametersInfo(SPI_SETSCREENSAVEACTIVE, Word(False), nil, 0);
//wyłączenie blokady......
SystemParametersInfo(SPI_SETSCREENSAVEACTIVE, Word(True), nil, 0);

21.   Zmiana rozdzielczosci ekranu.

funkcja SetScreenResolution bierze pożądaną szerokość i wysokość jako parametry i zwraca (zmienia) według innej funkcji API Windowsa - ChangeDisplaySettings.

function SetScreenResolution(Width, Height: integer): Longint;
var DeviceMode: TDeviceMode;
begin
with DeviceMode do begin
dmSize := SizeOf(TDeviceMode);
dmPelsWidth := Width;
dmPelsHeight := Height;
dmFields := DM_PELSWIDTH or DM_PELSHEIGHT;
end;
Result := ChangeDisplaySettings(DeviceMode, CDS_UPDATEREGISTRY);
end;

funkcji ChangeDisplaySettings można użyć , by zmienić inne własności takie jak głębia koloru czy częstotliwość pokazu

Poniższy przykład - button1 zmienia rozdzielczość ekrany na 800x600 ale przed tym zapamiętuje urozdzielczość dotychczasową. button2 - przywraca dotychczasowe ustawienia

var OldWidth, OldHeight: integer;

procedure TForm1.Button1Click(Sender: TObject);
begin
OldWidth := GetSystemMetrics(SM_CXSCREEN);
OldHeight := GetSystemMetrics(SM_CYSCREEN);
SetScreenResolution(800, 600);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
SetScreenResolution(OldWidth, OldHeight);
end;

22.   Funkcja zwiększająca dokładność zegara systemowego komputera.

Procedure TForm1.Button1Click(Send: TObject);
var loop1,loop2 : integer;   startcount, endcount, frequency : TLargeInteger;
Elapsedtime : Extended;
Begin
QueryPerformanceFrequency(Frequency)   {odczytaj aktualną częstotliwość zegara}
QueryPerformaceCounter(Startcount);   {Start odczytu}
For loop1 := 0 to 99 do
for loop2 := 0 to 99 do
StringGrid1.cells[loop2,loop1] := inttostr((loop1*100)+loop2);  {wstaw do celi Stringgrida}

QueryPerformanceCounter(Endcount);  {koniec odczytu}

Elapsedtime := (Endcount.Quadpart-Startcount.QuadPart)/Frequency.QuadPart;
{obliczony czas jaki upłynął na wykonanie tej funkcji}

Label1.Caption := 'Wykonanie w czasie : '+FloatTostr(ElapsedTime)+' sekund.';
End;

23.   Symulacja klikania myszy wariant 2.

Można łatwo symulować kliki myszy albo ruchy wg funkcji mouse_event.

Przykład: z chwilą włączenia programu ten pokazuje planszę jak gdyby użytkownik ustawił kursor myszy na pozycji x,y= 300,400 i dwukrotnie kliknął myszą - tą robotę wykonuje aktywny Timer.

procedure TForm1.FormCreateOrWhatever;
begin
winexec('myexternalapplication.exe',sw_shownormal);  // start aplikacji
timer1.interval:=2000;  // interwał zegara 2 sek -po tym czasie ruszy
timer1.enabled:=true;  // start zegara
end;

procedure TForm1.Timer1Timer(Sender: TObject);
var point:TPoint;  // daje aktualną pozycję kursora()
begin
getcursorpos(point);  // odczyt aktualnej pozycji
setcursorpos(300,400);  // przeniesiena na taką...
mouse_event(MOUSEEVENTF_LEFTDOWN,0,0,0,0); // wciśnięty klawisz myszy
mouse_event(MOUSEEVENTF_LEFTUP,0,0,0,0);  // +klawisz puszczony + 2-krotny klik
setcursorpos(point.x,point.y);  // ustawia kursor na poprzedniej pozycji
timer1.enabled:=false;  // stop
end;

Gdy program jest wykonywany -- ruchy myszą są zablokowane!

24.   Odczyt karty graficznej komputera.

Podanie na ListBoxa wykazu graficznych urządeń wyjściowych jakie są w komputerze dostępne

procedure TForm1.ButtonClick(Sender: TObject);
var lpDisplayDevice: TDisplayDevice; dwFlags: DWORD; cc: DWORD;
begin
lpDisplayDevice.cb := sizeof(lpDisplayDevice);
dwFlags := 0;   cc:= 0;
while EnumDisplayDevices(nil, cc, lpDisplayDevice , dwFlags) do begin
Inc(cc);
aListbox.Items.Add(lpDisplayDevice.DeviceString);  {dodawane są informacje z lpDisplayDevice}
end;
end;

Innym sposobem jest odczyt ustawień karty graficznej zapisany w rejestrze podczas instalacji systemu z następujących kluczy:

HKEY_LOCAL_MACHINE\System\CurrentControlSet\Services\Class\Display
%HKLM%\System\CurrentControlSet\Services\Class\Display\0000;
%HKLM%\System\CurrentControlSet\Services\Class\Display\0001;
%HKLM%\System\CurrentControlSet\Services\Class\Display\0002;

25.   Pokaz / Ustawienie rozmiaru fontów Menu systemowego.

{ odczyt rozmiaru czcionki }
function GetMenuFontSize: Integer;
var ncm: TNonClientMetrics; PixelsPerInch: integer;
begin
ncm.cbSize := sizeof(TNonClientMetrics);
SystemParametersInfo( SPI_GETNONCLIENTMETRICS, sizeof(NONCLIENTMETRICS),
@ncm, SPIF_UPDATEINIFILE );
PixelsPerInch := GetDeviceCaps(GetDC(0), LOGPIXELSY);
Result := -MulDiv(ncm.lfMenuFont.lfHeight, 72, PixelsPerInch);
end;

{ Ustawienie rozmiaru czcionki }
procedure SetMenuFontSize(FontSize: Integer);
var ncm: TNonClientMetrics; PixelsPerInch: Integer;
begin
ncm.cbSize := sizeof(TNonClientMetrics);
SystemParametersInfo( SPI_GETNONCLIENTMETRICS, sizeof(NONCLIENTMETRICS),
@ncm, 0 );
PixelsPerInch := GetDeviceCaps(GetDC(0), LOGPIXELSY);
ncm.lfMenuFont.lfHeight := -MulDiv(FontSize, PixelsPerInch, 72);
SystemParametersInfo( SPI_SETNONCLIENTMETRICS, sizeof(NONCLIENTMETRICS),
@ncm, SPIF_UPDATEINIFILE );
end;

26.   /Ukrycie / pokaz paska zadań -TaskBar.

Procedura EnableTaskbar znajduje okno paska zadań a potem ShowTasBar(false lub true) ukrywa lub pokazuje go:

procedure EnableTaskBar(Enable : boolean);
var hTaskBarWindow : HWnd;
begin
hTaskBarWindow:=FindWindow('Shell_TrayWnd',nil);
if hTaskBarWindow < > 0 then
EnableWindow(hTaskBarWindow,Enable);
end;

procedure ShowTaskbar(Visible: boolean);
var hTaskBarWindow : HWnd;
begin
hTaskBarWindow:=FindWindow('Shell_TrayWnd',nil);
if hTaskBarWindow < > 0 then
if Visible then
ShowWindow(hTaskBarWindow, SW_SHOW)
else
ShowWindow(hTaskBarWindow, SW_HIDE)
end;

27. Ochrona programów Shareware

Ten mały fragment kodu pozwala na szybkie tworzenie obrony shareware, która nie wpływa na funkcjonalność programu, ale "prosi", aby zarejestrować program. Program z tym kodem (jak shareware) może być użyty tylko 1 raz; ponowne użycie - po restarcie systemu. Bazuje na obsłudze zdarzenia - w Onformshow:

procedure tform1.formshow(sender: tobject);
var atom: integer; crlf: string;
begin
if globalfindatom('this_is_some_obscuree_text') = 0 then
atom := globaladdatom('this_is_some_obscuree_text') //unikalny string w PC
else begin
crlf := #10 + #13; //zmiana linii i na początek wiersza
showmessage('Ta wersja może być użyta tylko raz '
+ 'w danym seansie Windowsa.' + crlf
+ 'dla kolejnych uruchomień'
+ crlf + 'należy program ZAREJESTROWAĆ !');
close;
end; end;

28. Wykaz dysków komputera.

function driveexists(drive:byte):boolean;

function driveexists(drive:byte):boolean;
var drives: set of 0..25;
begin
integer(drives):=getlogicaldrives; result:=drive in drives
end;

function checkdrivetype(drive: byte): string;
var driveletter: char; drivetype: uint;
begin
driveletter:=chr(drive + $41); drivetype:=getdrivetype(pchar(driveletter + ':'));
case drivetype of
0: result:='?';
1: result:='ścieżka nie istnieje';
drive_removable: result:='removable'; drive_fixed: result:='fixed';
drive_remote: result:='remote'; drive_cdrom: result:='cd_rom';
drive_ramdisk: result:='ramdisk'
else
result:='nieznany' end
end;
var drives: set of 0..25;
begin
integer(drives):=getlogicaldrives; result:=drive in drives
end;

function checkdrivetype(drive: byte): string;
var driveletter: char; drivetype: uint;
begin
driveletter:=chr(drive + $41); drivetype:=getdrivetype(pchar(driveletter + ':'));
case drivetype of
0: result:='?';
1: result:='ścieżka nie istnieje';
drive_removable: result:='removable'; drive_fixed: result:='fixed';
drive_remote: result:='remote'; drive_cdrom: result:='cd_rom';
drive_ramdisk: result:='ramdisk'
else
result:='nieznany' end
end;

29. Programowa regulacja jasności i kontrastu monitora.

unit unit1;

interface

uses windows, messages, sysutils, variants, classes, graphics, controls, forms, dialogs, stdctrls;

type tform1 = class(tform)
button1: tbutton;
button2: tbutton;
procedure button1click(sender: tobject);
procedure button2click(sender: tobject);
procedure formcreate(sender: tobject);
procedure formdestroy(sender: tobject);
private { private declarations }
public { public declarations }
end;

var form1: tform1;

implementation
{$r *.dfm}
type tramparray=array[0..2] of array[byte] of word; //tablica przechowuje gamma kolorów
var origramparray:tramparray; // aktualne wartości gammy

//funkcja zmiany jasności - wbrightness - tym jaśniejszy
function setbrightness(wbrightness:word):boolean;
var ramparray:tramparray; i, value:integer; dc:hdc;
begin
for i:=0 to maxbyte do
begin
value := i * (wbrightness + 128); if (value > maxword) then value := maxword;
ramparray[0][i] := value; ramparray[1][i] := value; ramparray[2][i] := value;
end;
dc:=getdc(0); try result:= setdevicegammaramp(dc,ramparray)
finally releasedc(0,dc)
end end;

// zachowuje aktualne wartości gamma
procedure tform1.formcreate(sender: tobject);
var dc:hdc;
begin
dc:=getdc(0);
try getdevicegammaramp(dc,origramparray)
finally releasedc(0,dc)
end end;

// zmieniamy jasność
procedure tform1.button1click(sender: tobject);
begin
setbrightness(64)
end;

// przywracamy poprzednią gamme kolorów
procedure tform1.button2click(sender: tobject);
var dc:hdc;
begin
dc:=getdc(0);
try setdevicegammaramp(dc,origramparray)
finally releasedc(0,dc)
end end;

procedure tform1.formdestroy(sender: tobject);
begin
button2click(button2)
end;

end.

30. Odczyt numeru seryjnego dysku - 3 warianty

1.
Function GetVolumeInfoFVS(Const Dir:string;
Var FileSystemName,VolumeName:string;Var Serial:longint):boolean;
{pobieranie informacji o dysku
Dir - katalog lub wybrana partycja dysku
FileSystemName - nazwa systemu plików
VolumeName - etykieta dysku
Serial - numer seryjny dysku - w przypadku błędu funkcja zwraca False}
var root:pchar; res:longbool;
VolumeNameBuffer,FileSystemNameBuffer:pchar;
VolumeNameSize,FileSystemNameSize:DWord;
VolumeSerialNumber,MaximumComponentLength,FileSystemFlags:DWORD;
s:string; n:integer;
Begin
n:=pos(':',Dir); If n>0 Then s:=copy(Dir,1,n+1) Else s:=s+':';
If s[length(s)]=':' Then s:=s+'\'; root:=pchar(s);
getMem(VolumeNameBuffer,256); getMem(FileSystemNameBuffer,256);
VolumeNameSize:=255; FileSystemNameSize:=255;
res:=GetVolumeInformation(Root,VolumeNameBuffer,VolumeNameSize
,@VolumeSerialNumber, MaximumComponentLength, FileSystemFlags
,FileSystemNameBuffer,FileSystemNameSize);
Result:=res;
VolumeName:=VolumeNameBuffer; FileSystemName:=FileSystemNameBuffer;
Serial:=VolumeSerialNumber;
freeMem(VolumeNameBuffer,256); freeMem(FileSystemNameBuffer,256);
End;

2.
Function GetHDSerNo: shortstring; export;
var VolumeName, FileSystemName : array [0..MAX_PATH-1] of Char;
VolumeSerialNo : Cardinal; MaxComponentLength, FileSystemFlags : DWORD;
Begin
Try GetVolumeInformation('C:\',VolumeName,MAX_PATH,@VolumeSerialNo,
MaxComponentLength,FileSystemFlags, FileSystemName,MAX_PATH);
Result:=IntToHex(HiWord(VolumeSerialNo),4)+ '-'+IntToHex(LoWord(VolumeSerialNo),4);
Except;
End; End

3.
Procedure TForm1.Button1Click(SEnder: TObject);
var VolumeName,FileSystemName : array [0..MAX_PATH-1] of Char;
VolumeSerialNo : DWord;MaxComponentLength, FileSystemFlags : Cardinal;
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;

31. Określić, czy dokonano zmiany ustawienia ekranu.

type {...}
private
procedure wmdisplaychange(var msg: tmessage);
message wm_displaychange;
public {...}
end; end;

var form1: tform1;

implementation
{$r *.dfm}

procedure tform1.wmdisplaychange(var msg: tmessage);
begin
showmessage('wyswietlanie ekranu zmienione!');
inherited;
end;

32. Jak ustalić, czy są naciskane klawisze Shift, Alt lub Ctrl?

Poniższy przykład pokazuje, jak ustalić, czy naciśnięty klawisz Shift podczas wybierania wiersza menu.Przykład zawiera także klawisze stan funkcji Alt, Ctrl.

function CtrlDown : Boolean;
var State : TKeyboardState;
begin
GetKeyboardState(State); Result := ((State[vk_Control] And 128) < > 0);
end;

function ShiftDown : Boolean;
var State : TKeyboardState;
begin
GetKeyboardState(State); Result := ((State[vk_Shift] and 128) < > 0);
end;
function AltDown : Boolean;
var State : TKeyboardState;
begin
GetKeyboardState(State); Result := ((State[vk_Menu] and 128) < > 0);
end;

procedure TForm1.MenuItem12Click(Sender: TObject);
begin
if ShiftDown then Form1.Caption := 'Shift' else Form1.Caption := '';
end;

33. Jak uzyskać informacje o bios w systemie Windows NT/2000/XP?

W NT/2000/XP nie można odczytać wartości bezpośrednio z biosu, ale nic nie stoi na przeszkodzie, aby wziąć pod uwagę odpowiednie wartości z rejestru.

procedure tbiosinfo.getreginfowinnt;
var registryv : tregistry; regpath : string; sl : tstrings;
begin
params.clear;
regpath := '\hardware\description\system';
registryv:=tregistry.create;
registryv.rootkey:=hkey_local_machine;
sl := nil;
try
registryv.openkey(regpath,false);
showmessage('bios date: '+registryv.readstring('systembiosdate'));
sl := readmultirowkey(registryv,'systembiosversion');
showmessage('bios version: '+sl.text);
except
end; registryv.free; if assigned(sl) then sl.free;
end;

/ / Poniższa metoda pobiera wiele wartości z rejestru
/ / i zamienia je na TStringList
function readmultirowkey(reg: tregistry; key: string): tstrings;
const bufsize = 100;
var i: integer; s1: string; sl: tstringlist;
bin: array[1..bufsize] of char;
begin
try result := nil; sl := nil; sl := tstringlist.create;
if not assigned(reg) then
raise exception.create('tregistry object not assigned.');
fillchar(bin,bufsize,#0); reg.readbinarydata(key,bin,bufsize);
i := 1; s1 := '';
while i < bufsize do begin
if ord(bin[i]) >= 32 then
s1 := s1 + bin[i]
else begin
if length(s1) > 0 then begin
sl.add(s1); s1 := ''; end; end; inc(i); end; result := sl;
except
sl.free; raise; end;
end;

34. BIOS - odczyt danych

W NT/2000/XP nie być w stanie odczytać wartości bezpośrednio z biosu, ale nic nie stoi na przeszkodzie, aby wziąć pod uwagę odpowiednie wartości z rejestru.

procedure tbiosinfo.getreginfowinnt; //odczyt wersji biosu
var registryv: tregistry; regpath: string; sl: tstrings;
begin
params.clear; regpath := 'hardwaredescriptionsystem';
registryv := tregistry.create; registryv.rootkey := hkey_local_machine;
sl := nil;
try
registryv.openkey(regpath, false);
showmessage('bios date: ' + registryv.readstring('systembiosdate'));
sl := readmultirowkey(registryv, 'systembiosversion');
showmessage('bios version: ' + sl.text);
except
end; registryv.free; if assigned(sl) then sl.free;
end;

/ / Poniższa metoda pobiera wielu wartości z rejestru
/ / I zamienia je na TStringList
function readmultirowkey(reg: tregistry; key: string): tstrings;
const bufsize = 100;
var i: integer; s1: string; sl: tstringlist; bin: array[1..bufsize] of char;
begin
try result := nil; sl := nil; sl := tstringlist.create;
if not assigned(reg) then
raise exception.create('tregistry object not assigned.');
fillchar(bin, bufsize, #0);
reg.readbinarydata(key, bin, bufsize); i := 1; s1 := '';
while i < bufsize do
begin
if ord(bin[i]) >= 32 then s1 := s1 + bin[i]
else begin
if length(s1) > 0 then
begin
sl.add(s1); s1 := ''; end; end; inc(i); end; result := sl;
except
sl.free; raise; end;
end;

35. Wsparcie dla gorących klawiszy multimedialnych

Rozwiązać problem za pomocą winapi. Jeśli jesteś zainteresowany, tutaj jest mój kod:
unit unit1;

interface

uses windows, messages, forms;

type tform1 = class(tform)
procedure formcreate(sender: tobject);
private
procedure wm_hotkeyhandler (var message: tmessage);
message wm_hotkey;
public{ public declarations }
end;

var form1: tform1; hk_mute,hk_volumeup,hk_volumedown,hk_next,
hk_prev, hk_stop, hk_playpause:integer;

implementation
{$r *.dfm}

procedure tform1.wm_hotkeyhandler (var message: tmessage);
var idhotkey: integer; fumodifiers: word; hotkey: word;
begin
idhotkey:= message.wparam; fumodifiers:= loword(message.lparam);
hotkey:= hiword(message.lparam);
case hotkey of
173: caption:='mute'; 174: caption:='volumeup'; 175: caption:='volumedown';
176: caption:='nexttrack'; 177: caption:='prevtrack'; 178: caption:='stop';
179: caption:='play/pause'; end; inherited;
end;

procedure tform1.formcreate(sender: tobject);
begin
hk_mute:=globaladdatom('mute'); registerhotkey(handle,hk_mute,0,173);
hk_volumeup:=globaladdatom('volumeup'); registerhotkey(handle,hk_volumeup,0,174);
hk_volumedown:=globaladdatom('volumedown');
registerhotkey(handle,hk_volumedown,0,175);
hk_next:=globaladdatom('nexttrack'); registerhotkey(handle,hk_next,0,176);
hk_prev:=globaladdatom('prevtrack'); registerhotkey(handle,hk_prev,0,177);
hk_stop:=globaladdatom('stop'); registerhotkey(handle,hk_stop,0,178);
hk_playpause:=globaladdatom('play/pause');
registerhotkey(handle,hk_playpause,0,179);
end;

end.
Te przyciski nie przechwytują jeżeli są uruchomione inne aplikacje, które używają tych przycisków, np, Winamp.

36. Jak programowo zmienić tło pulpitu?

procedure tform1.formcreate(sender: tobject);
var st : string;
begin
st := 'c:\Obrazek.bmp';
systemparametersinfo(spi_setdeskwallpaper,uint(st), nil, spif_sendchange);
end;