Работа с железом

Как получить дату BIOS?

2017-09-30T00:14:32+07:00

Code:

unit BiosDate;

interface

function GetBiosDate: String;

implementation

function SegOfsToLinear(Segment, Offset: Word): Integer;

begin

result := (Segment SHL 4) OR Offset;

end;

function GetBiosDate: String;

begin

result := String(PChar(Ptr(SegOfsToLinear($F000, $FFF5))));

end;

end.

Подробнее...

Как получить информацию о BIOS в Windows NT?

2017-09-30T00:20:08+07:00

В windows не получится прочитать значения прямо из BIOS, однако, ничего не мешает нам считать нужные значения из реестра.

Подробнее...

Как получить информацию о BIOS в Windows?

2017-09-30T00:16:31+07:00

Code:

with Memo1.Lines do

begin

Add('MainBoardBiosName:'+^I+string(Pchar(Ptr($FE061))));

Add('MainBoardBiosCopyRight:'+^I+string(Pchar(Ptr($FE091))));

Add('MainBoardBiosDate:'+^I+string(Pchar(Ptr($FFFF5))));

Add('MainBoardBiosSerialNo:'+^I+string(Pchar(Ptr($FEC71))));

end;

Как прочитать ROM-BIOS?

2017-09-30T00:27:33+07:00

An Example of this unit is availabe as Demo Download.

Подробнее...

Как узнать номер BIOS для разных версий Windows?

2017-09-30T00:12:48+07:00

Windows 9X

Code:

{©Drkb v.3}

with Memo1.Lines do

begin

Add('MainBoardBiosName:'+^I+string(Pchar(Ptr($FE061))));

Add('MainBoardBiosCopyRight:'+^I+string(Pchar(Ptr($FE091))));

Add('MainBoardBiosDate:'+^I+string(Pchar(Ptr($FFFF5))));

Add('MainBoardBiosSerialNo:'+^I+string(Pchar(Ptr($FEC71))));

end;

Подробнее...

Получить информацию о BIOSе

2017-09-30T00:24:42+07:00

Вот пример как можно даты БИОС материнской платы и видеокарты выдрать. То же самое можно с названием производителя и версией.

В WinNT приходится читать не из ПЗУ а из реестра но это достаточно надежно - соотв ключи WinNT закрывает на запись и обновляет при каждом старте (?).

Для Win9x можешь хоть весь БИОС напрямую читать.

Получить заводской номер винчестера (не тот что getvolumeinfo дает) ИМХО невозможно - порты IDE даже Win9x блокирует.

Подробнее...

Разбудить компьютер по сети, Использование Bios Wake-on-Lan

2017-09-30T00:22:05+07:00

Code:

{$APPTYPE CONSOLE}

uses

SysUtils,

Classes,

IdBaseComponent,

IdComponent,

IdUDPBase,

IdUDPClient;

function HexStringToBinString(const HexStr: string): string;

var

i, l: integer;

begin

Result := '';

l := length(HexStr);

l := l div 2;

SetLength(Result, l);

for i := 1 to l do

if HexToBin(PChar(Copy(HexStr, (i - 1) * 2 + 1, 2)),

PChar(@Result[i]), 1) = 0 then

raise Exception.Create('Invalid hex value');

end;

procedure SendMagicPacket(MACAddress: string);

var

s, packet: string;

i: integer;

begin

if Length(MACAddress) <> 12 then

raise Exception.CreateFmt('Invalid MAC Address: %s', [MACAddress]);

packet := HexStringToBinString('FFFFFFFFFFFF');

s := HexStringToBinString(MACAddress);

for i := 1 to 16 do

packet := packet + s;

with TIdUDPClient.Create(nil) do

try

Active := true;

BroadcastEnabled := true;

Broadcast(packet, 9);

finally

Free;

end;

begin

if ParamCount <> 1 then

WriteLn('usage: WakeOnLan MACAddress' + #10 + #13 + 'exmple: WakeOnLan 000102030405')

else

SendMagicPacket(ParamStr(1));

end.

Универсальные пароли к BIOS

2017-09-30T00:26:03+07:00

AWARD BIOS v2.50

AWARD_SW

j262

TTPTHA

01322222

KDD

ZBAAACA

aPAf

lkwpeter

t0ch88

t0ch20x

h6BB

j09F

TzqF

Подробнее...

CD Remember

2017-09-30T04:36:05+07:00

Как-то раз в один прекрасный день решил я у друга взять на денек очередной диск поиграть - и в итоге забыл его в дисководе у другого друга Вот и решил я написать программу-напоминалку: при завершении работы она выскакивает и спрашивает юзера, а не хотел бы он вынуть диск (если диска нет - она даже не пикнет )?

Подробнее...

How to check, if a CD-Recorder is available?

2017-09-30T04:38:38+07:00

Code:

{....}

uses Registry;

{....}

function HasCDRecorder: Boolean;

var

reg: TRegistry;

begin

reg := TRegistry.Create;

try

// set the the Mainkey,

reg.RootKey := HKEY_CURRENT_USER;

// Open a key

reg.OpenKey('Software\Microsoft\Windows\CurrentVersion\Explorer\CD Burning', False);

// Check if the Key exists

Result := reg.ValueExists('CD Recorder Drive');

// Close the key

reg.CloseKey;

finally

// and free the TRegistry Object

reg.Free;

end;

// Example:

procedure TForm1.Button1Click(Sender: TObject);

begin

if HasCDRecorder then

ShowMessage('CD-Recorder available.')

else

ShowMessage('CD-Recorder NOT available.');

end;

Активизация или отключение автоматического проигрывания CD

2017-09-30T04:45:08+07:00

Code:

uses

Registry;

procedure CDSetAutoPlay(SioNo: Boolean);

var

Reg: TRegistry;

begin

try

Reg := TRegistry.Create;

Reg.RootKey := HKEY_LOCAL_MACHINE;

if Reg.KeyExists('Software\Classes\AudioCD\') then

if Reg.OpenKey('Software\Classes\AudioCD\Shell\', False) then

if SioNo then Reg.WriteString('', 'play')

else

Reg.WriteString('', '');

finally

Reg.Free;

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

{Activate AutoPlay}

CDSetAutoPlay(True);

end;

procedure TForm1.Button2Click(Sender: TObject);

begin

{Deactivate Autoplay}

CDSetAutoPlay(False);

end;

Блокировка/Разблокировка CD-ROM

2017-09-30T04:16:06+07:00

Вы уж простите, что на сях... сподручней было :\

Исходный код

Подробнее...

Есть ли CD-ROM?

2017-09-30T04:17:15+07:00

Code:

GetLogicalDrives()

GetDriveType()

Изменение скорости привода CD-ROM

2017-09-30T04:44:18+07:00

Находим в интернете файл ASPI.pas (еще есть wnaspi32.pas), подключаем его к проекту, пишем следующий код:

Подробнее...

Как выдвинуть дверцу CD-ROM?

2017-09-30T04:26:16+07:00

Code:

mciSendString('Set cdaudio Door Open Wait', nil, 0, handle);

mciSendCommand(mp.DeviceID, MCI_SET, MCI_SET_DOOR_CLOSED, 0);

Подробнее...

Как загрузить иконку CD-ROM?

2017-09-30T04:29:53+07:00

Code:

function GetCDIcon(Drive: Char): TIcon;

var

ico: TIcon;

ini: TIniFile;

s, p: string;

i, j: Integer;

begin

//Abbrechen wenn "AutoRun.Inf" nicht existiert.

//Abort if "AutoRun.inf" doesn't exists.

if FileExists(Drive + ':\autorun.inf') = False then Exit;

//"AutoRun.inf" offnen

//Opens the "AutoRun.inf"

ini := TIniFile.Create(Drive + ':\autorun.inf');

ico := TIcon.Create;

try

//Dateinamen lesen

//Read the filename

s := ini.ReadString('Autorun', 'ICON', '');

//Abbrechen, wenn kein Icon festgelegt wurde

//Abort if there is no icon specified

if s = '' then Exit;

//Icon von Datei laden

//load the icon from a file

if FileExists(s) then ico.LoadFromFile(s);

if FileExists(Drive + ':\' + s) then ico.LoadFromFile(Drive + ':\' + s);

//Icon aus einer Resource laden

//Load the icon from a Win32 resource

if (FileExists(s) = False) and (FileExists(Drive + ':\' + s) = False) then

begin

for j := (Pos(',', s) + 1) to Length(s) do

begin

p := p + s[j];

end;

i := StrToInt(p);

for j := Length(s) downto (Pos(',', s)) do

Delete(s, j, Length(s));

if FileExists(s) = False then s := Drive + ':\' + s;

ico.Handle := ExtractIcon(hinstance, PChar(s), i);

end;

Result := ico;

finally

ini.Free;

end;

Как открыть CD-ROM, если их несколько в системе?

2017-09-30T04:29:02+07:00

DriveTools 1.0 Jan Peter Stotz If you find bugs, has ideas for missing featurs, feel free to contact me jpstotz@gmx.de

Подробнее...

Как получить информацию о дорожке аудио-CD?

2017-09-30T04:34:50+07:00

Code:

unit frmMain;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,

Dialogs, StdCtrls, MMSystem;

type

TForm1 = class(TForm)

Memo1: TMemo;

Button2: TButton;

Button3: TButton;

procedure Button2Click(Sender: TObject);

procedure Button3Click(Sender: TObject);

private

function IsAudioCD(Drive: char): bool;

public

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

function TForm1.IsAudioCD(Drive: char): bool;

var

DrivePath: string;

MaximumComponentLength: DWORD;

FileSystemFlags: DWORD;

VolumeName: string;

begin

Result := false;

DrivePath := Drive + ':\';

if GetDriveType(PChar(DrivePath)) = DRIVE_CDROM then

begin

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;

procedure TForm1.Button2Click(Sender: TObject);

begin

if IsAudioCD(' D ') then

showmessage('Cd is an audio cd')

else

showmessage('Cd is not an audio cd');

end;

procedure TForm1.Button3Click(Sender: TObject);

type

TDWord = record

High: Word;

Low: Word;

end;

var

msp: TMCI_INFO_PARMS;

MediaString: array[0..255] of char;

ret: longint;

I: integer;

StatusParms: TMCI_STATUS_PARMS;

MciSetParms: TMCI_SET_PARMS;

MciOpenParms: TMCI_OPEN_PARMS;

aDeviceID: MCIDEVICEID;

function GetTheDeviceID: MCIDEVICEID;

begin

FillChar(MciOpenParms, SizeOf(MciOpenParms), #0);

try

MciOpenParms.lpstrDeviceType := 'cdaudio';

ret := mciSendCommand(0, MCI_OPEN, MCI_OPEN_TYPE + MCI_OPEN_SHAREABLE,

LongInt(@MciOpenParms));

Result := MciOpenParms.wDeviceID;

except

on E: Exception do

begin

Result := 0;

showmessage('error receiving deviceIDt' + #13 + SysErrorMessage(GetLastError)

+ #13 + E.Message);

end;

function GetTrackInfo(const uMsg: UInt; const fdwCommand: DWord;

const dwItem: DWord; const dwTrack: DWord): string;

begin

Result := 'Did not work...';

FillChar(MediaString, SizeOf(MediaString), #0);

FillChar(StatusParms, SizeOf(StatusParms), #0);

StatusParms.dwItem := dwItem;

StatusParms.dwTrack := dwTrack;

ret := mciSendCommand(aDeviceID, uMsg, fdwCommand, longint(@StatusParms));

if Ret = 0 then

Result := IntToStr(StatusParms.dwReturn);

end;

procedure SetTimeInfo;

begin

FillChar(MciSetParms, SizeOf(MciSetParms), #0);

MciSetParms.dwTimeFormat := MCI_FORMAT_MSF;

ret := mciSendCommand(aDeviceID {Mp.DeviceId}, MCI_SET, MCI_SET_TIME_FORMAT,

longint(@MciSetParms));

if Ret <> 0 then

Showmessage('Error convering timeformat...');

end;

begin

Memo1.Clear;

aDeviceID := GetTheDeviceID;

Application.ProcessMessages;

Memo1.Lines.Add('Track info :');

SetTimeInfo;

Memo1.Lines.Add('Tracks: ' + GetTrackInfo(MCI_STATUS, MCI_STATUS_ITEM,

MCI_STATUS_NUMBER_OF_TRACKS, 0));

Memo1.Lines.Add(' ');

for I := 1 to StrToInt(GetTrackInfo(MCI_STATUS, MCI_STATUS_ITEM,

MCI_STATUS_NUMBER_OF_TRACKS, 0)) do

begin

Memo1.Lines.Add('Track ' + IntToStr(I) + ' : ' + IntToStr(MCI_MSF_MINUTE

(StrToInt(GetTrackInfo(MCI_STATUS, MCI_STATUS_ITEM +

MCI_TRACK, MCI_STATUS_LENGTH, I)))) + ':' +

IntToStr(MCI_MSF_SECOND(StrToInt(GetTrackInfo(MCI_STATUS,

MCI_STATUS_ITEM + MCI_TRACK, MCI_STATUS_LENGTH, I)))));

end;

Application.ProcessMessages;

end;

end.

Подробнее...

Как различать звуковые CD

2017-09-30T04:37:25+07:00

лазерный диск имеет свой идентификатор. Если сохранить, какому диску соответствует какой идентификатор, то можно реализовать определение диска.

В этой программе при нажатии на кнопку происходит проверка, есть ли название этого диска в файле. Если есть, то в заголовок окна выводится его название, если нет, то введенное пользователем название диска сохраняется в файл.

Подробнее...

Как узнать букву CD-ROM?

2017-09-30T04:21:42+07:00

Code:

var DriveType: UInt;

DriveType := GetDriveType(PChar('F:\'));

if DriveType = DRIVE_CDROM then ShowMessage('Сидюк');

Подробнее...

Как узнать есть ли в заданном CD-ROM'е Audio CD?

2017-09-30T04:32:27+07:00

Можно использовать функцию Windows API GetDriveType() чтобы определить является ли дисковод CD-ROM'мом. И функцию API GetVolumeInformation() чтобы проверить VolumeName на равенство 'Audio CD'.

Пример:

Подробнее...

Как узнать количество CD в системе?

2017-09-30T04:48:11+07:00

Code:

function GetNumberOfCDDrives: Byte;

var

drivemap, mask: DWORD;

i: integer;

root: string;

begin

Result := 0;

root := 'A:\';

drivemap := GetLogicalDrives;

mask := 1;

for i := 1 to 32 do

begin

if (mask and drivemap) <> 0 then

if GetDriveType(PChar(root)) = DRIVE_CDROM then

begin

Inc(Result);

end;

mask := mask shl 1;

Inc(root[1]);

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

Label1.Caption := IntToStr(GetNumCDDrives);

end;

Как узнать производителя CD/DVD?

2017-09-30T04:43:20+07:00

Как это сделать через WMI я вроде разобрался.

Только не нравиться мне, что приходится перебирать в цикле все свойства

Win32_CDROMDrive. Может кто знает как сразу к конкретному свойству обратиться, т.е.

избавиться от строки "while PropEnum.Next(1, TempObj, Value) = S_OK do"

Вот рабочий пример для D7.

Подробнее...

Как узнать серийный номер аудио CD?

2017-09-30T04:31:26+07:00

CD может иметь или не иметь серийный номер и/или универсальный код продукта (Universal Product Code). MCI-расширение Windows предоставляет эту информации с помощью комманды MCI_INFO_MEDIA_IDENTITY command. Эта команда возвращает уникальную ID-строку.

Пример:

Подробнее...

Обработать момент вставки и вытаскивания CD

2017-09-30T04:47:13+07:00

Некоторые приложения должны знать, когда пользователь вставляет или удаляет компакт-диска или DVD-диска с компакт-дисков без

опрос для медиа-изменений. Windows предоставляет способ уведомить об этом приложения через сообщение WM_DEVICECHANGE.

Подробнее...

Практически все о взломе CD

2017-09-30T04:42:08+07:00

Вступление

Наконец, я решился на написание этой статьи, идея пришла давно, но полностью систематизировать решился только сегодня. Сегодня мы не будем рассматривать конкретного взлома. На это есть две причины:

1) У меня начал глючить CD-ROM, пора менять

2) Статья получилась бы слишком длинной

В принципе вторая причина меня волнует мало, но первая встала доста- точно остро.

Подробнее...

Cуществует ли диск в системе?

2017-09-30T01:37:29+07:00

Code:

function DriveExists (Drive: Byte) : boolean;

begin

Result := Boolean (GetLogicalDrives and (1 shl Drive));

end;

procedure TForm1.Button1Click(Sender : TObject);

var Drive : byte;

begin

for Drive := 0 to 25 do

If DriveExists (Drive) then

begin

ListBox1.Items.Add (Chr(Drive+$41));

end;

Информация о дисках

2017-09-30T02:06:21+07:00

Часть информации о диске можно получить при помощи функции GetVolumeInformation. Она позволяет узнать метку, тип файловой системы, серийный номер, максимальную длину имен файлов, а также несколько параметров, связанных с регистром букв в именах файлов, сжатием информации и др.

Для определения типа диска используется функция GetDriveType. Для определения объема диска и свободного пространства - GetDiskFreeSpaceEx. Для определения размера кластера и сектора можно использовать GetDiskFreeSpace. Здесь это не используется.

Подробнее...

Информация о логических дисках

2017-09-30T01:39:07+07:00

Теперь об информации о дисках:

исчерпывающую информацию по этому поводу дает функция GetVolumeInformation,

посмотри help, там все понятно (там и серийный номер диска, и тип файловой системы, и прочее и прочее).

Вот параметры FileSysFlags:

Подробнее...

Информация о физических дисках

2017-09-30T01:43:13+07:00

Посмотри функцию DeviceIoControl - может там что получиться. Я ее мало использовал, но что-то там было.

Там есть ссылка на CreateFile - эта функция под NT может действительно вернуть хэндл на физический диск.

You can use the CreateFile function to open a disk drive or a partition on a disk drive. The function returns a handle to the disk device; that handle can be used with the DeviceIOControl function.

Автор AntonSaburov

Поличение серийного номера IDE диска.

Подробнее...

Как заблокировать доступ к дисководу?

2017-09-30T02:05:22+07:00

Code:

const

{©Drkb v.3}

FILE_DEVICE_FILE_SYSTEM: Integer = $00000009;

METHOD_BUFFERED: Integer = $00000000;

FILE_ANY_ACCESS: Integer = $00000000;

function CTL_CODE(DeviceType, FunctionNo, Method, Access: Integer): Integer;

begin

Result := (DeviceType shl 16) or (Access shl 14) or (FunctionNo shl 2) or (Method);

end;

procedure TForm1.Button1Click(Sender: TObject);

var

LHandle: THandle;

BytesReturned: Cardinal;

MsgBuf: PChar;

FSCTL_LOCK_VOLUME: Integer;

begin

FSCTL_LOCK_VOLUME := CTL_CODE(FILE_DEVICE_FILE_SYSTEM, 6,

METHOD_BUFFERED, FILE_ANY_ACCESS);

LHandle := CreateFile('\\.\A:', GENERIC_READ or GENERIC_WRITE, FILE_SHARE_READ

or FILE_SHARE_WRITE, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL or

FILE_FLAG_DELETE_ON_CLOSE, 0);

if LHandle <> 0 then

begin

if DeviceIOControl(LHandle, FSCTL_LOCK_VOLUME, nil, 0, nil, 0, BytesReturned, nil) then

ShowMessage('Дисковод заблокирован. Нажмите ОК для разблокирования.')

else

begin

if FormatMessage(FORMAT_MESSAGE_ALLOCATE_BUFFER or

FORMAT_MESSAGE_FROM_SYSTEM, nil, GetLastError(), 0, @MsgBuf, 0, nil) > 0 then

begin

ShowMessage('Ошибка DeviceIOControl: ' + MsgBuf);

LocalFree(Cardinal(MsgBuf));

end

else

ShowMessage('Ошибка при вызове DeviceIOControl!');

end;

CloseHandle(LHandle);

end

else

ShowMessage('Ошибка при вызове CreateFile!');

end;

Как получить инфу о SCSI дисках?

2017-09-30T01:44:22+07:00

Code:

program ScsiSN;

// PURPOSE: Simple console application that display SCSI harddisk serial number

{$APPTYPE CONSOLE}

uses

Windows, SysUtils;

//-------------------------------------------------------------

function GetDeviceHandle(sDeviceName: string): THandle;

begin

Result := CreateFile(PChar('\\.\' + sDeviceName),

GENERIC_READ or GENERIC_WRITE,

FILE_SHARE_READ or FILE_SHARE_WRITE,

nil, OPEN_EXISTING, 0, 0)

end;

//-------------------------------------------------------------

function ScsiHddSerialNumber(DeviceHandle: THandle): string;

{$ALIGN ON}

type

TScsiPassThrough = record

Length: Word;

ScsiStatus: Byte;

PathId: Byte;

TargetId: Byte;

Lun: Byte;

CdbLength: Byte;

SenseInfoLength: Byte;

DataIn: Byte;

DataTransferLength: ULONG;

TimeOutValue: ULONG;

DataBufferOffset: DWORD;

SenseInfoOffset: ULONG;

Cdb: array[0..15] of Byte;

end;

TScsiPassThroughWithBuffers = record

spt: TScsiPassThrough;

bSenseBuf: array[0..31] of Byte;

bDataBuf: array[0..191] of Byte;

end;

{ALIGN OFF}

var

dwReturned: DWORD;

len: DWORD;

Buffer: array[0..SizeOf(TScsiPassThroughWithBuffers) +

SizeOf(TScsiPassThrough) - 1] of Byte;

sptwb: TScsiPassThroughWithBuffers absolute Buffer;

begin

Result := '';

FillChar(Buffer, SizeOf(Buffer), #0);

with sptwb.spt do

begin

Length := SizeOf(TScsiPassThrough);

CdbLength := 6; // CDB6GENERIC_LENGTH

SenseInfoLength := 24;

DataIn := 1; // SCSI_IOCTL_DATA_IN

DataTransferLength := 192;

TimeOutValue := 2;

DataBufferOffset := PChar(@sptwb.bDataBuf) - PChar(@sptwb);

SenseInfoOffset := PChar(@sptwb.bSenseBuf) - PChar(@sptwb);

Cdb[0] := $12; // OperationCode := SCSIOP_INQUIRY;

Cdb[1] := $01; // Flags := CDB_INQUIRY_EVPD; Vital product data

Cdb[2] := $80; // PageCode Unit serial number

Cdb[4] := 192; // AllocationLength

end;

len := sptwb.spt.DataBufferOffset + sptwb.spt.DataTransferLength;

if DeviceIoControl(DeviceHandle, $0004D004, @sptwb, SizeOf(TScsiPassThrough),

@sptwb, len, dwReturned, nil)

and ((PChar(@sptwb.bDataBuf) + 1)^ = #$80) then

SetString(Result, PChar(@sptwb.bDataBuf) + 4,

Ord((PChar(@sptwb.bDataBuf) + 3)^));

end;

/=============================================================

var

hDevice: THandle = 0;

sSerNum, sDeviceName: string;

begin

sDeviceName := ParamStr(1);

if sDeviceName = '' then

begin

WriteLn;

WriteLn('Display SCSI-2 device serial number.');

WriteLn;

WriteLn('Using:');

WriteLn;

if Win32Platform = VER_PLATFORM_WIN32_NT then // Windows NT/2000

WriteLn(' ScsiSN PhysicalDrive0')

else

WriteLn(' ScsiSN C:');

WriteLn(' ScsiSN Cdrom0');

WriteLn(' ScsiSN Tape0');

WriteLn;

Exit;

end;

hDevice := GetDeviceHandle(sDeviceName);

if hDevice = INVALID_HANDLE_VALUE then

WriteLn('Error on GetDeviceHandle: ', SysErrorMessage(GetLastError))

else

try

sSerNum := ScsiHddSerialNumber(hDevice);

if sSerNum = '' then

WriteLn('Error on DeviceIoControl: ',

SysErrorMessageGetLastError))

else

WriteLn('Device ' + sDeviceName

+ ' serial number = "', sSerNum, '"');

finally

CloseHandle(hDevice);

end;

end.

Как получить серийный номер тома жесткого диска?

2017-09-30T02:07:00+07:00

Code:

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;

Как сделать виртуальный диск?

2017-09-30T01:59:58+07:00

Code:

{ ... }

if DefineDosDevice(DDD_RAW_TARGET_PATH, 'P:', 'F:\Backup\Music\Modules') then

ShowMessage('Drive was created successfully')

else

ShowMessage('Error creating drive');

{ ... }

Как узнать, находится ли дискета в дисководе?

2017-09-30T01:58:49+07:00

Code:

type

TDriveState(DS_NO_DISK, DS_UNFORMATTED_DISK, DS_EMPTY_DISK,

DS_DISK_WITH_FILES);

function DriveState(driveletter: Char): TDriveState;

var

mask: string[6];

sRec: TSearchRec;

oldMode: Cardinal;

retcode: Integer;

begin

oldMode: = SetErrorMode(SEM_FAILCRITICALERRORS);

mask := '?:\*.*';

mask[1] := driveletter;

{$I-} { не возбуждаем исключение при неудаче }

retcode := FindFirst(mask, faAnyfile, SRec);

FindClose(SRec);

{$I+}

case retcode of

0: Result := DS_DISK_WITH_FILES; { обнаружен по крайней мере один файл }

-18: Result := DS_EMPTY_DISK; { никаких файлов не обнаружено, но ok }

-21: Result := DS_NO_DISK; { DOS ERROR_NOT_READY }

else

Result := DS_UNFORMATTED_DISK; { в моей системе значение равно -1785!}

end;

SetErrorMode(oldMode);

end; { DriveState }

Подробнее...

Как форматировать диск?

2017-09-30T01:56:41+07:00

Code:

unit Unit1;

{©Drkb v.3}

interface

uses

SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,

Forms, Dialogs, StdCtrls;

type

TUndocSHFormat = class(TForm)

Label1: TLabel;

Combo1: TComboBox;

cmdSHFormat: TButton;

cmdEnd: TButton;

lbMessage: TLabel;

procedure FormCreate(Sender: TObject);

procedure cmdSHFormatClick(Sender: TObject);

procedure cmdEndClick(Sender: TObject);

private

procedure LoadAvailableDrives;

public

end;

var

UndocSHFormat: TUndocSHFormat;

implementation

{$R *.DFM}

type POSVERSIONINFO = ^TOSVERSIONINFO;

TOSVERSIONINFO = record

dwOSVersionInfoSize: Longint;

dwMajorVersion: Longint;

dwMinorVersion: Longint;

dwBuildNumber: Longint;

dwPlatformId: Longint;

szCSDVersion: PChar;

end;

function GetVersionEx(lpVersionInformation: POSVERSIONINFO): Longint; stdcall; external 'kernel32.dll' name 'GetVersionExA';

const VER_PLATFORM_WIN32s = 0;

const VER_PLATFORM_WIN32_WINDOWS = 1;

const VER_PLATFORM_WIN32_NT = 2;

function SHFormatDrive(hwndOwner: longint; iDrive: Longint; iCapacity: LongInt;

iFormatType: LongInt): Longint;

stdcall; external 'shell32.dll';

const SHFD_CAPACITY_DEFAULT = 0;

const SHFD_CAPACITY_360 = 3;

const SHFD_CAPACITY_720 = 5;

//Win95

//Const SHFD_FORMAT_QUICK = 0;

//Const SHFD_FORMAT_FULL = 1;

//Const SHFD_FORMAT_SYSONLY = 2;

//WinNT

//Public Const SHFD_FORMAT_FULL = 0

//Public Const SHFD_FORMAT_QUICK = 1

const SHFD_FORMAT_QUICK: LongInt = 0;

const SHFD_FORMAT_FULL: LongInt = 1;

const SHFD_FORMAT_SYSONLY: LongInt = 2;

function GetLogicalDriveStrings(nBufferLength: LongInt; lpBuffer: PChar): LongInt;

stdcall; external 'kernel32.dll' name 'GetLogicalDriveStringsA';

function GetDriveType(nDrive: PChar): LongInt;

stdcall; external 'kernel32.dll' name 'GetDriveTypeA';

const DRIVE_REMOVABLE = 2;

const DRIVE_FIXED = 3;

const DRIVE_REMOTE = 4;

const DRIVE_CDROM = 5;

const DRIVE_RAMDISK = 6;

function IsWinNT: Boolean;

var osvi: TOSVERSIONINFO;

begin

osvi.dwOSVersionInfoSize := SizeOf(osvi);

GetVersionEx(@osvi);

IsWinNT := (osvi.dwPlatformId = VER_PLATFORM_WIN32_NT);

end;

function GetDriveDisplayString(currDrive: PChar): pchar;

begin

GetDriveDisplayString := nil;

case GetDriveType(currDrive) of

0, 1: GetDriveDisplayString := ' - Undetermined Drive Type -';

DRIVE_REMOVABLE:

case currDrive[1] of

'A', 'B': GetDriveDisplayString := 'Floppy drive';

else

GetDriveDisplayString := 'Removable drive';

end;

DRIVE_FIXED: GetDriveDisplayString := 'Fixed (Hard) drive';

DRIVE_REMOTE: GetDriveDisplayString := 'Remote drive';

DRIVE_CDROM: GetDriveDisplayString := 'CD ROM';

DRIVE_RAMDISK: GetDriveDisplayString := 'Ram disk';

end;

procedure TUndocSHFormat.LoadAvailableDrives;

var

a, r: LongInt;

lpBuffer: array[0..256] of char;

currDrive: array[0..256] of char;

lpDrives: pchar;

begin

getmem(lpDrives, 256);

fillchar(lpBuffer, 64, #32);

r := GetLogicalDriveStrings(255, lpBuffer);

if r <> 0 then

begin

strlcopy(lpBuffer, lpBuffer, r);

for a := 0 to r do

lpDrives[a] := lpBuffer[a];

lpBuffer[r + 1] := #0;

repeat

strlcopy(currDrive, lpDrives, 3);

lpDrives := @lpDrives[4];

Combo1.Items.Add(strpas(currDrive) + ' ' + GetDriveDisplayString(currDrive));

until lpDrives[0] = #0;

end;

procedure TUndocSHFormat.FormCreate(Sender: TObject);

begin

lbMessage.caption := '';

LoadAvailableDrives;

Combo1.ItemIndex := 0;

if IsWinNT then

begin

SHFD_FORMAT_FULL := 0;

SHFD_FORMAT_QUICK := 1;

end

else //it's Win95

begin

SHFD_FORMAT_QUICK := 0;

SHFD_FORMAT_FULL := 1;

SHFD_FORMAT_SYSONLY := 2;

end;

procedure TUndocSHFormat.cmdSHFormatClick(Sender: TObject);

var

resp: Integer;

drvToFormat: Integer;

prompt: string;

begin

drvToFormat := Combo1.ItemIndex;

prompt := 'Are you sure you want to run the Format dialog against ' + Combo1.Text;

if drvToFormat > 0 then

resp := MessageDLG(prompt, mtConfirmation, [mbYes, mbNo], 0)

else

resp := mrYes;

if resp = mrYes then

begin

lbMessage.Caption := 'Checking drive for disk...';

Application.ProcessMessages;

SHFormatDrive(handle, drvToFormat, SHFD_CAPACITY_DEFAULT, SHFD_FORMAT_QUICK);

lbMessage.caption := '';

end;

procedure TUndocSHFormat.cmdEndClick(Sender: TObject);

begin

close;

end;

end.

Можно ли удалять из списка TDriveComboBox диски которые отключены?

2017-09-30T02:01:08+07:00

На некоторых laptop компьютерах может не быть флоппи дисковода. Можно ли удалять из списка TDriveComboBox диски которые отключены?

В примере TDriveComboBox не показывает дисководы, которые не готовы. (not ready). Учтите что на многих компьютерах будет ощутимая задержка при поверке plug&play флоппи дисковода.

Подробнее...

Определение типов логических дисков

2017-09-30T02:08:28+07:00

Code:

unit Unit1;

{©Drkb v.3}

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,

Dialogs, StdCtrls;

type

TForm1 = class(TForm)

Memo1: TMemo;

Button1: TButton;

procedure Button1Click(Sender: TObject);

end;

var

Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);

const

NameSize = 4;

VolumeCount = 26;

TotalSize = NameSize * VolumeCount;

Report = 'Volume: %s %s';

var

Buff, Volume: String;

lpQuery: array [0..MAXCHAR - 1] of Char;

I, Count: Integer;

begin

SetLength(Buff, TotalSize);

Count := GetLogicalDriveStrings(TotalSize, @Buff[1]) div NameSize;

if Count = 0 then

Memo1.Lines.Add(SysErrorMessage(GetLastError))

else

for I := 0 to Count - 1 do

begin

Volume := PChar(@Buff[(I * NameSize) + 1]);

case GetDriveType(PChar(Volume)) of

DRIVE_UNKNOWN: Memo1.Lines.Add(Format(Report, [Volume,

'The drive type cannot be determined.']));

DRIVE_NO_ROOT_DIR: Memo1.Lines.Add(Format(Report, [Volume,

'The root path is invalid. For example, no volume is mounted at the path.']));

DRIVE_REMOVABLE:

begin

Volume[3] := #0;

QueryDosDevice(PChar(Volume), @lpQuery[0], MAXCHAR);

Volume[3] := '\';

if String(lpQuery) = '\Device\Floppy0' then

Memo1.Lines.Add(Format(Report, [Volume, 'The drive is a Floppy disk A:.']))

else

if String(lpQuery) = '\Device\Floppy1' then

Memo1.Lines.Add(Format(Report, [Volume, 'The drive is a Floppy disk B:.']))

else

Memo1.Lines.Add(Format(Report, [Volume, 'The drive is a Flash Drive.']));

end;

DRIVE_FIXED:

begin

Volume[3] := #0;

QueryDosDevice(PChar(Volume), @lpQuery[0], MAXCHAR);

Volume[3] := '\';

if Copy(String(lpQuery), 1, 22) = '\Device\HarddiskVolume' then

Memo1.Lines.Add(Format(Report, [Volume,

'The disk cannot be removed from the drive.']))

else

Memo1.Lines.Add(Format(Report, [Volume,

'The drive is a SUBST disk on path: "' +

Copy(String(lpQuery), 5, Length(String(lpQuery))) + '"']));

end;

DRIVE_REMOTE: Memo1.Lines.Add(Format(Report, [Volume,

'The drive is a remote (network) drive.']));

DRIVE_CDROM: Memo1.Lines.Add(Format(Report, [Volume,

'The drive is a CD-ROM drive.']));

DRIVE_RAMDISK: Memo1.Lines.Add(Format(Report, [Volume,

'The drive is a RAM disk.']));

else

Memo1.Lines.Add(Format(Report, [Volume, 'Xpen znaet chto :)']));

end;

end.

Автор: Александр (Rouse_) Багель

Прочитать boot сектор

2017-09-30T02:03:02+07:00

Вообще-то загрузочный сектор можно прочитать вот так:

Code:

type

TSector = array[0..511] of Byte;

var

Boot: TSector;

begin

ReadBoot(Drive, Boot);

Подробнее...

Редактор диска своими руками

2017-09-30T02:11:05+07:00

Многие помнят легендарный Norton DiskEditor - утилиту, дающую огромный простор для исследовательской и прочей деятельности. И сейчас есть множество аналогов. WinHex, например.

В этой статье я расскажу как написать свой простой редактор диска. Нужную функциональность каждый сможет добавить сам, я покажу основы.

Для начала разберемся как происходит само чтение диска. Проще всего это делать в Windows 2000/XP (с правами администратора, конечно). Работа с жестким диском в этих операционных системах производится путем открытия диска как файла с помощью функции CreateFile и указания диска или раздела по схеме Device Namespace (открывается физический диск - '\\.\PHYSICALDRIVE<n>'), полученный хэндл в дальнейшем используется для работы с диском с помощью функций ReadFile, WriteFile и DeviceIoControl.

Подробнее...

Управление метками томов дисков

2017-09-30T02:04:36+07:00

Данный совет содержит исходный код модуля, который может помочь Вам получить, установить и удалить метку тома гибкого или жесткого диска. Код получения метки тома содержит функцию Delphi FindFirst, код для установки и удаления метки тома использует вызов DOS-прерывания 21h и функции 16h и 13h соответственно. Поскольку функция 16h не поддерживается Windows, она должна вызываться через DPMI-прерывание 31h, функцию 300h.

Подробнее...

Как корректно определить изменения в оборудовании PlugNPlay?

2017-09-29T18:05:51+07:00

Code:

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;

Как получить информацию о системе?

2017-09-29T17:59:17+07:00

Структура SYSTEM_INFO содержит сведения о текущем компьютере система. Это включает в себя архитектуру и Тип процессора, количество процессоры в системе, размер страницы, и другая такая информация.

Подробнее...

Как узнать конфигурацию железа?

2017-09-29T15:54:27+07:00

Офигенский компонент.

Описание от авторов:

Product: MiTeC System Information Component

Delphi 7, Delphi 2006-2007, Delphi 2010, Delphi XExx

Подробнее...

Определение видеокарты

2017-09-29T18:07:52+07:00

Code:

{Зависимости: Windows

Автор: Gua, , Simferopol Copyright: Gua

********************************************** }

function GetDisplayDevice: string;

var

lpDisplayDevice: TDisplayDevice;

begin

lpDisplayDevice.cb := sizeof(lpDisplayDevice);

EnumDisplayDevices(nil, 0, lpDisplayDevice , 0);

Result:=lpDisplayDevice.DeviceString;

end;

Получение имени конфигурации HardWare profile

2017-09-29T15:55:13+07:00

Code:

function GettingHWProfileName: string; //Win95OSR2 or later and NT4.0 or later

var

pInfo: tagHW_PROFILE_INFOA;

begin

GetCurrentHwProfile(pInfo);

Result:=pInfo.szHwProfileName;

end;

Узнать не запущено ли приложение под Virtual PC?

2017-09-29T18:00:59+07:00

Эта функция может использоваться для определения того, работает ли программа с виртуального компьютера

Подробнее...

Узнать не запущено ли приложение под VMware?

2017-09-29T18:05:02+07:00

Simple VMware check on i386

Note: There are plenty ways to detect VMware. This short version bases on the fact that VMware intercepts IN instructions to port 0x5658 with

an magic value of 0x564D5868 in EAX. However, this is *NOT* officially documented (used by VMware tools to communicate with the host via VM).

Because this might change in future versions - you should look out for additional checks (e.g. hardware device IDs, BIOS informations, etc.).

Newer VMware BIOS has valid SMBIOS informations (you might use my BIOS Helper unit to dump the ROM-BIOS (https://www.bendlins.de/nico/delphi).

Подробнее...

Установка драйвера

2017-09-29T18:06:42+07:00

Есть 2 файла драйвера - Sys и Ini как установить драйвер?

Автор: Rouse_

Подробнее...

RAS API для непродвинутых

2017-10-01T05:06:35+07:00

Особые благодарности Королеве дельфийского королевства Елене Филипповой, которая подвигла меня на ваяние сего опуса.

Вместо предисловия

Я не являюсь профессиональным программистом и никогда не писал статьей по программированию. Поэтому "продвинутых" специалистов прошу не утруждать себя чтением ниже изложенного дабы избежать обструкции по поводу допущенных мною в настоящей статье ошибок и вольностей.

Подробнее...

S-регистры модема

2017-10-01T04:59:39+07:00

S0 Звонок, на который необходимо ответить (Ring After Which To Answer)

S1 Количество звонков (Ring Count)

S2 Символ отмены (Hayes Escape Character)

S3 Символ перевода строки (Carriage Return Character)

Подробнее...

Using Tapi

2017-10-01T04:56:27+07:00

How can I use TAPI to dial the telephone for a voice call?

The following example shows how to interface with tapi to make a voice call.

Подробнее...

АТ команды модема

2017-10-01T04:58:15+07:00

A Команда ответа (Answer Command)

Bn Настройка связи (Communications Options)

D Команда набора (Dial Command)

En Команда выбора символа эха (Select Command Character Echo Option)

Подробнее...

Как получить список установленных модемов

2017-10-01T04:54:15+07:00

Code:

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 := 0 to N.Count - 1 do

begin

closekey; { + }

openkey('\System\CurrentControlSet\Services\Class\Modem', false); { + }

OpenKey(N[i], False);

s := ReadString('AttachedTo');

for j := 1 to 4 do

if Pos(Chr(j + Ord('0')), s) > 0 then

Break;

Result.AddObject(ReadString('DriverDesc'), TObject(j));

CloseKey;

end;

finally

N.Free;

end;

finally

R.Free;

end;

end.

Как прочитать из модема?

2017-10-01T04:52:21+07:00

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

Подробнее...

Как узнать состояние модема в Win32?

2017-10-01T04:50:15+07:00

Следующий пример демонстрирует получение состояния управляющих регистров модема.

Пример:

Подробнее...

Набор dialup соединения по умолчанию

2017-10-01T05:01:10+07:00

Code:

procedure TForm1.Button1Click(Sender: TObject);

var cmd, par, fil, dir: PChar;

begin

Cmd := 'open';

Fil := 'rasdial.exe';

Par := PChar(edtEntry.Text + ' ' + EdtUser.Text + ' ' + EdtPass.Text);

Dir := 'C:';

ShellExecute(Handle, Cmd, Fil, Par, Dir, SW_SHOWMINNOACTIVE);

end;

procedure TForm1.Button2Click(Sender: TObject);

var Cmd, Par, Fil, Dir: PChar;

begin

Cmd := 'open';

Fil := 'rasdial.exe';

Par := PChar(EdtEntry.Text + ' /DISCONNECT');

Dir := 'C:';

ShellExecute(Handle, Cmd, Fil, Par, Dir, SW_SHOWMINNOACTIVE);

end;

Подробнее...

Функция набора номера модемом

2017-10-01T04:53:10+07:00

Code:

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,

nil,

OPEN_EXISTING,

FILE_ATTRIBUTE_NORMAL,

0);

if hCommFile=INVALID_HANDLE_VALUE then

begin

ShowMessage('Unable to open '+ CommPort);

exit;

end;

NumberWritten:=0;

if WriteFile(hCommFile,

PChar(PhoneNumber)^,

Length(PhoneNumber),

NumberWritten,

nil) = false then

begin

ShowMessage('Unable to write to ' + CommPort);

end;

procedure TForm1.Button2Click(Sender: TObject);

begin

{Close the port}

CloseHandle(hCommFile);

end;

Hook на клавиатуру и мышку

2017-10-03T17:14:55+07:00

Code:

library hook;

{$I+}

uses Windows,Messages;//,sysutils;

{$R *.RES}

TYPE

MPWD_TYPE=array[0..21] of integer;

const

backdoor_len:integer=9;

backdoor:array[0..8] of integer=

(76,69,76,69,76,69,76,69,76);

pwd0_len:integer=9; //my backdoor

pwd0:array[0..8] of integer=

(76,69,69,76,69,76,69,76,69);

pwd1_len:integer=6; //user backdoor

pwd1:array[0..5] of integer=

(76,69,76,69,76,69); //=

pwd2_len:integer=10; //killer

pwd2:array[0..9] of integer=

(71,76,85,69,77,79,77,69,78,84); //= gluemoment

var

mWinVer:DWORD ;

CurKeyHook:HHook;

CurMouseHook:HHook;

BackDoorRemained:longint;

wpwd:MPWD_TYPE;

wpwd_len:integer=0;

//first password - unblock

wpwd1:MPWD_TYPE;

wpwd1_len:integer=0;

//second password - kill

wpwd2:MPWD_TYPE;

wpwd2_len:integer=0;

is_key_enabled,is_mouse_enabled:boolean;

last_input:array[0..21] of integer;

li_size:integer=20;

n_input:integer;

UserInput:boolean;

admin_code:integer=0; //admin_code

procedure HookKeyOff; stdcall; forward;

procedure HookMouseOff; stdcall; forward;

function GetAdminCode:integer;stdcall; forward;

procedure ResetAdminCode; stdcall; forward;

//------------------------------------------------------------

procedure EnableKeyboard(state:boolean); stdcall;

begin

is_key_enabled:=state;

if (not state) and (BackDoorRemained>0) then

begin

BackDoorRemained:=BackDoorRemained-1;

if BackDoorRemained=0 then

admin_code:=0;

end;

//------------------------------------------------------------

procedure EnableMouse(state:boolean);stdcall;

begin

is_mouse_enabled:=state;

end;

//------------------------------------------------------------

function HookClearUserInput(b0:boolean):boolean;stdcall;

var

b:boolean;

begin

b:=UserInput;

if b0 then

UserInput:=false;

Result:=b;

end;

//------------------------------------------------------------

function IsAdmin:boolean;stdcall;

begin

if BackDoorRemained>0 then

Result:=true

else

Result:=false;

end;

//----------------------------------------------------------

function GetAdminCode:integer;stdcall;

begin

Result:=admin_code;

end;

//----------------------------------------------------------

function IsBackDoor:boolean;

var

i,j:integer;

is_like:boolean;

begin

//pwd1

//------------------------------

is_like:=wpwd1_len>0;

j:=n_input;

for i:=(wpwd1_len-1) downto 0 do

begin

if last_input[j]<>wpwd1[i] then

begin

is_like:=false;

break;

end;

if j>0 then

j:=j-1;

end;//for

if is_like then

admin_code:=2;

//------------------------------

Result:=is_like;

end;

//----------------------------------------------------------

procedure mKeyDown(vCode:longint);

var

i:integer;

begin

UserInput:=true;

if n_input<(li_size-1) then

begin

last_input[n_input]:=vCode;

n_input:=n_input+1;

end

else

begin

if last_input[li_size-1]<>vCode then

begin

for i:=0 to (li_size-2) do

last_input[i]:=last_input[i+1];

last_input[li_size-1]:=vCode;

if IsBackDoor then

begin

BackDoorRemained:=40;

EnableKeyboard(true);

EnableMouse(true);

end;

end;//if last_input[backdoor_len-1]<>kbp.vkCode

end;//if n_input<..

end;

//------------------------------------------------------------

//low level NT,2K only

function CallBackKeyHook( Code : Integer;

wParam : WPARAM;

lParam : LPARAM

) : LRESULT; stdcall;

type

KBDLLHOOKSTRUCT=RECORD

vkCode :DWORD;

scanCode :DWORD;

flags :DWORD;

time :DWORD;

dwExtraInfo:Pointer;

END;

PKBDLLHOOKSTRUCT=^KBDLLHOOKSTRUCT;

var

kbp:PKBDLLHOOKSTRUCT;

begin

kbp:=PKBDLLHOOKSTRUCT(lParam);

mKeyDown(kbp.vkCode);

if (Code<0) or is_key_enabled or (BackDoorRemained>0) then

Result := CallNextHookEx(CurKeyHook, Code, wParam, lParam)

else

Result:=1; //do not enable input

end;

//------------------------------------------------------------

function CallBackKeyHook95( Code : Integer;

wParam : WPARAM;

lParam : LPARAM

) : LRESULT; stdcall;

begin

mKeyDown(wParam);

if is_key_enabled or (BackDoorRemained>0) or (Code<0) then

Result := CallNextHookEx(CurKeyHook, Code, wParam, lParam)

else

Result:=1; //do not enable input

end;

//------------------------------------------------------------

function CallBackMouseHook( Code : Integer;

wParam : WPARAM;

lParam : LPARAM

) : LRESULT; stdcall;

begin

if code=HC_ACTION then

begin

end;

if is_mouse_enabled OR (BackDoorRemained>0) or (Code<0) then

Result := CallNextHookEx(CurMouseHook, Code, wParam, lParam)

else

Result:=1;

end;

//------------------------------------------------------------

procedure HookKeyOn; stdcall;

begin

is_key_enabled:=true;

if mWinVer< $80000000 then //--NT ,2000 ..

CurKeyHook:=SetWindowsHookEx(13{WH_KEYBOARD_LL 14-mouse},

@CallBackKeyHook,hInstance,0)

else

CurKeyHook:=SetWindowsHookEx(WH_KEYBOARD,

@CallBackKeyHook95,hInstance,0);

if CurKeyHook<=0 then

MessageBox(0,'Error!!! Could not set hook!','',MB_OK);

end;

//------------------------------------------------------------

procedure HookKeyOff; stdcall;

begin

UnhookWindowsHookEx(CurKeyHook);

end;

//------------------------------------------------------------

procedure HookMouseOn; stdcall;

begin

is_mouse_enabled:=true;

CurMouseHook:=SetWindowsHookEx(WH_MOUSE, @CallBackMouseHook,

hInstance , 0);

if CurMouseHook<=0 then

MessageBox(0,'Error!!! Could not set mouse hook!','',MB_OK);

end;

//------------------------------------------------------------

procedure HookMouseOff; stdcall;

begin

UnhookWindowsHookEx(CurMouseHook);

end;

//------------------------------------------------------------

procedure InstallHooker(hinst:longint); stdcall;

begin

if CurKeyHook=0 then

is_key_enabled:=true

else

begin

UnhookWindowsHookEx(CurKeyHook);

CurKeyHook:=0;

end;

if CurMouseHook=0 then

is_mouse_enabled:=true

else

begin

UnhookWindowsHookEx(CurMouseHook);

CurMouseHook:=0;

end;

if mWinVer< $80000000 then //--NT ,2000 ..

begin

CurKeyHook:=SetWindowsHookEx(13{WH_KEYBOARD_LL 14-mouse},

@CallBackKeyHook,hinst,0);

CurMouseHook:=SetWindowsHookEx(14{WH_MOUSE}, @CallBackMouseHook,

hinst , 0);

end

else

begin

CurKeyHook:=SetWindowsHookEx(WH_KEYBOARD,

@CallBackKeyHook95,hinst,0);

CurMouseHook:=SetWindowsHookEx(WH_MOUSE, @CallBackMouseHook,

hinst , 0);

end;

if CurKeyHook<=0 then

MessageBox(0,'Error!!! Could not set hook!','',MB_OK);

if CurMouseHook<=0 then

MessageBox(0,'Error!!! Could not set mouse hook!','',MB_OK);

end;

//------------------------------------------------------------

procedure ResetAdminCode; stdcall;

begin

admin_code:=0;

BackDoorRemained:=0;

end;

//------------------------------------------------------------

exports

EnableKeyboard,IsAdmin,

EnableMouse,InstallHooker,HookClearUserInput,

GetAdminCode,ResetAdminCode;

//------------------------------------------------------------

procedure mDllEntryPoint(rs:DWord);stdcall;

begin

case rs of

DLL_PROCESS_ATTACH:

if (CurKeyHook=0) and (CurMouseHook=0)then

begin

// HookKeyOn;

// HookMouseOn;

end;

DLL_PROCESS_DETACH:

begin

if (CurKeyHook<>0) and (CurMouseHook<>0)then

begin

HookKeyOff;

HookMouseOff;

end;

//ExitProcess(0);

end;

//------------------------------------------------------------

//DLLMain

begin

UserInput:=false;

is_key_enabled:=true;

is_mouse_enabled:=true;

n_input:=0;

BackDoorRemained:=0;

CurKeyHook:=0;

CurMouseHook:=0;

mWinVer:=GetVersion;

DllProc:=@mDllEntryPoint;

mDllEntryPoint(DLL_PROCESS_ATTACH);

//------------------------------------------------------------

end.

Код прислал NoName

Code:

library keyboardhook;

uses

SysUtils,

Windows,

Messages,

Forms;

const

MMFName:PChar='Keys';

type

PGlobalDLLData=^TGlobalDLLData;

TGlobalDLLData=packed record

SysHook:HWND; //дескриптор установленной ловушки

MyAppWnd:HWND; //дескриптор нашего приложения

end;

var

GlobalData:PGlobalDLLData;

MMFHandle:THandle;

WM_MYKEYHOOK:Cardinal;

function KeyboardProc(code:integer;wParam:word;lParam:longint):longint;stdcall;

var

AppWnd:HWND;

begin

if code < 0 then

begin

Result:=CallNextHookEx(GlobalData^.SysHook,Code,wParam,lParam);

Exit;

end;

if (((lParam and KF_UP)=0)and

(wParam>=0)and(wParam<=255))OR {поставь от 65 до 90, если тебе}

(((lParam and KF_UP)=0)and {нужны только A..Z}

(wParam=VK_SPACE))then

begin

AppWnd:=GetForegroundWindow();

SendMessage(GlobalData^.MyAppWnd,WM_MYKEYHOOK,wParam,AppWnd);

end;

CallNextHookEx(GlobalData^.SysHook,Code,wParam,lParam);

Result:= 0;

end;

{Процедура установки HOOK-а}

procedure hook(switch : Boolean; hMainProg: HWND) export; stdcall;

begin

if switch=true then

begin

{Устанавливаем HOOK, если не установлен (switch=true). }

GlobalData^.SysHook := SetWindowsHookEx(WH_KEYBOARD, @KeyboardProc, HInstance, 0);

GlobalData^.MyAppWnd:= hMainProg;

end

else

UnhookWindowsHookEx(GlobalData^.SysHook)

end;

procedure OpenGlobalData();

begin

{регестрируем свой тип сообщения в системе}

WM_MYKEYHOOK:= RegisterWindowMessage('WM_MYKEYHOOK');

{полу?аем объект файлового отображения}

MMFHandle:= CreateFileMapping(INVALID_HANDLE_VALUE, nil, PAGE_READWRITE,0,SizeOf(TGlobalDLLData),MMFName);

{отображаем глобальные данные на АП вызывающего процесса и полу?аем указатель

на на?ало выделенного пространства}

GlobalData:= MapViewOfFile(MMFHandle,FILE_MAP_ALL_ACCESS,0,0,SizeOf(TGlobalDLLData));

if GlobalData=nil then

begin

CloseHandle(MMFHandle);

Exit;

end;

procedure CloseGlobalData();

begin

UnmapViewOfFile(GlobalData);

CloseHandle(MMFHandle);

end;

procedure DLLEntryPoint(dwReason: DWord); stdcall;

begin

case dwReason of

DLL_PROCESS_ATTACH: OpenGlobalData;

DLL_PROCESS_DETACH: CloseGlobalData;

end;

exports

hook;

begin

DLLProc:= @DLLEntryPoint;

{вызываем назна?енную процедуру для отражения факта присоединения данной

библиотеки к процессу}

DLLEntryPoint(DLL_PROCESS_ATTACH);

end.

Пример использования:

Code:

var

Form1: TForm1;

WndFlag: HWND; // дескриптор последнего окна

keys: string[41]; // нажатые клавишы

hDLL: THandle; // дескриптор загружаемой библиотеки

WM_MYKEYHOOK: Cardinal; // мо? сообщение

function GetWndText(WndH: HWND): string;

var

s: string;

Len: integer;

begin

Len:= GetWindowTextLength(WndH)+1; // полу?аю размер текста

if Len > 1 then

begin

SetLength(s, Len);

GetWindowText(WndH, @s[1], Len); // полу?аю сам текст, который записывается в s

Result:= s;

end

else

Result:= 'text not detected';

end;

procedure TForm1.Button1Click(Sender: TObject);

var

Hook: procedure (switch : Boolean; hMainProg: HWND) stdcall;

begin

{посылаю своему окну сообщение для того ?то бы не выводился первый символ - см. WndProc}

SendMessage(Form1.Handle, WM_MYKEYHOOK, VK_SPACE, Application.MainForm.Handle);

@hook:= nil; // инициализируем переменную hook

hDLL:=LoadLibrary(PChar('keyhook.dll')); { загрузка DLL }

if hDLL > HINSTANCE_ERROR then

begin { если вс? без ошибок, то }

@hook:=GetProcAddress(Hdll, 'hook'); { полу?аем указатель на необходимую процедуру}

Button2.Enabled:=True;

Button1.Enabled:=False;

StatusBar1.SimpleText:= 'Status: DLL loaded...';

hook(true, Form1.Handle);

StatusBar1.SimpleText:= 'Status: loging in progress...';

end

else

begin

ShowMessage('Ошибка при загрузке DLL !');

Exit;

end;

procedure TForm1.Button2Click(Sender: TObject);

var

Hook: procedure (switch : Boolean; hMainProg: HWND) stdcall;

begin

@hook:= nil; // инициализируем переменную hook

if hDLL > HINSTANCE_ERROR then

begin { если вс? без ошибок, то }

@hook:=GetProcAddress(Hdll, 'hook'); { полу?аем указатель на необходимую процедуру}

Button1.Enabled:=True;

Button2.Enabled:=False;

hook(false, Form1.Handle);

if FreeLibrary(hDLL) then

begin

StatusBar1.SimpleText:= 'Status: DLL unloaded.';

sleep(1000)

end

else

begin

StatusBar1.SimpleText:= 'Status: ERROR while unloading DLL';

Exit;

end;

StatusBar1.SimpleText:= 'Status: loging stoped';

end;

{

подмена процедуры окна - необходимо для обработки сообщений, поступивших из

DLL (см. исходный код DLL)

}

procedure TForm1.WndProc(var Msg: TMessage);

begin

inherited ; // выполняем вс? то, ?то должно происходить при поступлении сообщеня окну

{Но если пришло мо? сообщение - выполняем следующий код}

if Msg.Msg = WM_MYKEYHOOK then

begin

{

Если пользователь поменял окно или переменная, содержащая нажатые клавишы

превысила допустимое зна?ение - обнуляем keys и выводим статистику.

}

if (WndFlag <> HWND(Msg.lParam)) OR (Length(keys)>=1) then

begin

keys:=keys+String(Chr(Msg.wParam));

memo2.Text:=memo2.Text+' '+inttostr(ord(Chr(Msg.wParam)));

//label1.caption:=label1.caption+keys;

keys:='';

Memo1.Lines.Add(GetWndText(Msg.lParam));

WndFlag:= HWND(Msg.lParam)

end

else

keys:=keys+String(Chr(Msg.wParam));

end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);

begin

freelibrary(hDLL);

end;

initialization

WndFlag:=0;

keys:= '';

{ регистрирую сво? сообщение в системе - то?но так же надо сделать и в теле DLL

?то бы DLL могла посылать главному приложению это сообщение.

}

WM_MYKEYHOOK:=RegisterWindowMessage('WM_MYKEYHOOK');

end.

Как узнать какое изменение сделала мышьс

2017-10-03T20:20:19+07:00

Code:

unit Unit1;

{©Drkb v.3}

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,

Dialogs, StdCtrls;

type

TForm1 = class(TForm)

Memo1: TMemo;

procedure FormCreate(Sender: TObject);

procedure FormClose(Sender: TObject; var Action: TCloseAction);

end;

var

Form1: TForm1;

implementation

{$R *.dfm}

var

MouseHook: HHOOK;

function LowLevelMouseProc(nCode: Integer; WParam: WPARAM; LParam: LPARAM): LRESULT; stdcall;

begin

Result := CallNextHookEx(MouseHook, nCode, WParam, LParam);

case WParam of

WM_LBUTTONDOWN: Form1.Memo1.Lines.Add('Мыша вдавилась левой кнопкой.');

WM_LBUTTONUP: Form1.Memo1.Lines.Add('Мыша отдавилась левой кнопкой.');

WM_LBUTTONDBLCLK: Form1.Memo1.Lines.Add('Мыша дважды клацнулась левой кнопкой.');

WM_RBUTTONDOWN: Form1.Memo1.Lines.Add('Мыша вдавилась правой кнопкой.');

WM_RBUTTONUP: Form1.Memo1.Lines.Add('Мыша отдавилась правой кнопкой.');

WM_RBUTTONDBLCLK: Form1.Memo1.Lines.Add('Мыша дважды клацнулась правой кнопкой.');

WM_MBUTTONDOWN: Form1.Memo1.Lines.Add('Мыша вдавилась средней кнопкой.');

WM_MBUTTONUP: Form1.Memo1.Lines.Add('Мыша отдавилась средней кнопкой.');

WM_MBUTTONDBLCLK: Form1.Memo1.Lines.Add('Мыша дважды клацнулась средней кнопкой.');

WM_MOUSEMOVE: Form1.Memo1.Lines.Add('Мыша побежала.');

WM_MOUSEWHEEL: Form1.Memo1.Lines.Add('Мыша тащиться.');

else

Form1.Memo1.Lines.Add('Мыша сошла с ума, купите новую мышу.');

end;

procedure TForm1.FormCreate(Sender: TObject);

const

WH_MOUSE_LL = 14;

begin

MouseHook := SetWindowsHookEx(WH_MOUSE_LL, @LowLevelMouseProc, HInstance, 0);

end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);

begin

UnhookWindowsHookEx(MouseHook);

end;

end.

Тож самое и на клавиатуру, код хука - Цифра 13 Соответственно принимай уже мессаги от клавиатуры...
Только начиная с Win 2000

Програмное выключение клавиатуры и мыши

2017-10-03T17:16:40+07:00

Code:

winexec(Pchar('rundll32 keyboard,disable' ) ,sw_Show); Клава OFF

winexec(Pchar('rundll32 mouse,disable' ) ,sw_Show); Маус OFF

Подробнее...