Как прочитать байт из параллельного порта

Как объяснить тупому, что такое бит? Элементарно — это байт минус налоги. Как объяснить тупому, что такое байт? Элементарно — объясните ему 8 раз, что такое бит. Что такое килобайт? Это слишком долго рассказывать…

var

BytesRead: BYTE;

begin

asm { Читаем порт (LPT1) через встроенный ассемблер }

MOV dx,$379;

in al,dx;

MOV BytesRead,al;

end;

BytesRead := (BytesRead or $07); { OR а затем XOR данных }

BytesRead := (BytesRead xor $80); { маскируем неиспользуемые биты }

end;

Как программно установить конфигурацию COM-порта

procedure TForm1.Button1Click(Sender: TObject);

var

CommPort: string;

hCommFile: THandle;

Buffer: PCommConfig;

size: DWORD;

begin

CommPort := 'COM1';

{Открываем Com-порт}

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;

{Выделяем временный буфер}

GetMem(Buffer, sizeof(TCommConfig));

{Получаем размер структуры CommConfig}

size := 0;

GetCommConfig(hCommFile, Buffer^, size);

{Освобождаем временный буфер}

FreeMem(Buffer, sizeof(TCommConfig));

{Выделяем память для структуры CommConfig}

GetMem(Buffer, size);

GetCommConfig(hCommFile, Buffer^, size);

{Изменяем скорость передачи}

Buffer^.dcb.BaudRate := 1200;

{Устанавливаем новую конфигурацию для COM-порта}

SetCommConfig(hCommFile, Buffer^, size);

{Освобождаем буфер}

FreeMem(Buffer, size);

{Закрываем COM-порт}

CloseHandle(hCommFile);

end;

Ассинхронная связь

unit Comm;

interface

uses

Messages, WinTypes, WinProcs, Classes, Forms;

type

TPort = (tptNone, tptOne, tptTwo, tptThree, tptFour, tptFive, tptSix,

tptSeven,

tptEight);

TBaudRate = (tbr110, tbr300, tbr600, tbr1200, tbr2400, tbr4800, tbr9600,

tbr14400,

tbr19200, tbr38400, tbr56000, tbr128000, tbr256000);

TParity = (tpNone, tpOdd, tpEven, tpMark, tpSpace);

TDataBits = (tdbFour, tdbFive, tdbSix, tdbSeven, tdbEight);

TStopBits = (tsbOne, tsbOnePointFive, tsbTwo);

TCommEvent = (tceBreak, tceCts, tceCtss, tceDsr, tceErr, tcePErr, tceRing,

tceRlsd,

tceRlsds, tceRxChar, tceRxFlag, tceTxEmpty);

TCommEvents = set of TCommEvent;

const

PortDefault = tptNone;

BaudRateDefault = tbr9600;

ParityDefault = tpNone;

DataBitsDefault = tdbEight;

StopBitsDefault = tsbOne;

ReadBufferSizeDefault = 2048;

WriteBufferSizeDefault = 2048;

RxFullDefault = 1024;

TxLowDefault = 1024;

EventsDefault = [];

type

TNotifyEventEvent = procedure(Sender: TObject; CommEvent: TCommEvents) of

object;

TNotifyReceiveEvent = procedure(Sender: TObject; Count: Word) of object;

TNotifyTransmitEvent = procedure(Sender: TObject; Count: Word) of object;

TComm = class(TComponent)

private

FPort: TPort;

FBaudRate: TBaudRate;

FParity: TParity;

FDataBits: TDataBits;

FStopBits: TStopBits;

FReadBufferSize: Word;

FWriteBufferSize: Word;

FRxFull: Word;

FTxLow: Word;

FEvents: TCommEvents;

FOnEvent: TNotifyEventEvent;

FOnReceive: TNotifyReceiveEvent;

FOnTransmit: TNotifyTransmitEvent;

FWindowHandle: hWnd;

hComm: Integer;

HasBeenLoaded: Boolean;

Error: Boolean;

procedure SetPort(Value: TPort);

procedure SetBaudRate(Value: TBaudRate);

procedure SetParity(Value: TParity);

procedure SetDataBits(Value: TDataBits);

procedure SetStopBits(Value: TStopBits);

procedure SetReadBufferSize(Value: Word);

procedure SetWriteBufferSize(Value: Word);

procedure SetRxFull(Value: Word);

procedure SetTxLow(Value: Word);

procedure SetEvents(Value: TCommEvents);

procedure WndProc(var Msg: TMessage);

procedure DoEvent;

procedure DoReceive;

procedure DoTransmit;

protected

procedure Loaded; override;

public

constructor Create(AOwner: TComponent); override;

destructor Destroy; override;

procedure Write(Data: PChar; Len: Word);

procedure Read(Data: PChar; Len: Word);

function IsError: Boolean;

published

property Port: TPort read FPort write SetPort default PortDefault;

property BaudRate: TBaudRate read FBaudRate write SetBaudRate

default BaudRateDefault;

property Parity: TParity read FParity write SetParity default ParityDefault;

property DataBits: TDataBits read FDataBits write SetDataBits

default DataBitsDefault;

property StopBits: TStopBits read FStopBits write SetStopBits

default StopBitsDefault;

property WriteBufferSize: Word read FWriteBufferSize

write SetWriteBufferSize default WriteBufferSizeDefault;

property ReadBufferSize: Word read FReadBufferSize

write SetReadBufferSize default ReadBufferSizeDefault;

property RxFullCount: Word read FRxFull write SetRxFull

default RxFullDefault;

property TxLowCount: Word read FTxLow write SetTxLow default TxLowDefault;

property Events: TCommEvents read FEvents write SetEvents

default EventsDefault;

property OnEvent: TNotifyEventEvent read FOnEvent write FOnEvent;

property OnReceive: TNotifyReceiveEvent read FOnReceive write FOnReceive;

property OnTransmit: TNotifyTransmitEvent read FOnTransmit write

FOnTransmit;

end;

procedure Register;

implementation

procedure TComm.SetPort(Value: TPort);

const

CommStr: PChar = 'COM1:';

begin

FPort := Value;

if (csDesigning in ComponentState) or

(Value = tptNone) or (not HasBeenLoaded) then

exit;

if hComm >= 0 then

CloseComm(hComm);

CommStr[3] := chr(48 ord(Value));

hComm := OpenComm(CommStr, ReadBufferSize, WriteBufferSize);

if hComm < 0 then

begin

Error := True;

exit;

end;

SetBaudRate(FBaudRate);

SetParity(FParity);

SetDataBits(FDataBits);

SetStopBits(FStopBits);

SetEvents(FEvents);

EnableCommNotification(hComm, FWindowHandle, FRxFull, FTxLow);

end;

procedure TComm.SetBaudRate(Value: TBaudRate);

var

DCB: TDCB;

begin

FBaudRate := Value;

if hComm >= 0 then

begin

GetCommState(hComm, DCB);

case Value of

tbr110: DCB.BaudRate := CBR_110;

tbr300: DCB.BaudRate := CBR_300;

tbr600: DCB.BaudRate := CBR_600;

tbr1200: DCB.BaudRate := CBR_1200;

tbr2400: DCB.BaudRate := CBR_2400;

tbr4800: DCB.BaudRate := CBR_4800;

tbr9600: DCB.BaudRate := CBR_9600;

tbr14400: DCB.BaudRate := CBR_14400;

tbr19200: DCB.BaudRate := CBR_19200;

tbr38400: DCB.BaudRate := CBR_38400;

tbr56000: DCB.BaudRate := CBR_56000;

tbr128000: DCB.BaudRate := CBR_128000;

tbr256000: DCB.BaudRate := CBR_256000;

end;

SetCommState(DCB);

end;

end;

procedure TComm.SetParity(Value: TParity);

var

DCB: TDCB;

begin

FParity := Value;

if hComm < 0 then

exit;

GetCommState(hComm, DCB);

case Value of

tpNone: DCB.Parity := 0;

tpOdd: DCB.Parity := 1;

tpEven: DCB.Parity := 2;

tpMark: DCB.Parity := 3;

tpSpace: DCB.Parity := 4;

end;

SetCommState(DCB);

end;

procedure TComm.SetDataBits(Value: TDataBits);

var

DCB: TDCB;

begin

FDataBits := Value;

if hComm < 0 then

exit;

GetCommState(hComm, DCB);

case Value of

tdbFour: DCB.ByteSize := 4;

tdbFive: DCB.ByteSize := 5;

tdbSix: DCB.ByteSize := 6;

tdbSeven: DCB.ByteSize := 7;

tdbEight: DCB.ByteSize := 8;

end;

SetCommState(DCB);

end;

procedure TComm.SetStopBits(Value: TStopBits);

var

DCB: TDCB;

begin

FStopBits := Value;

if hComm < 0 then

exit;

GetCommState(hComm, DCB);

case Value of

tsbOne: DCB.StopBits := 0;

tsbOnePointFive: DCB.StopBits := 1;

tsbTwo: DCB.StopBits := 2;

end;

SetCommState(DCB);

end;

procedure TComm.SetReadBufferSize(Value: Word);

begin

FReadBufferSize := Value;

SetPort(FPort);

end;

procedure TComm.SetWriteBufferSize(Value: Word);

begin

FWriteBufferSize := Value;

SetPort(FPort);

end;

procedure TComm.SetRxFull(Value: Word);

begin

FRxFull := Value;

if hComm < 0 then

exit;

EnableCommNotification(hComm, FWindowHandle, FRxFull, FTxLow);

end;

procedure TComm.SetTxLow(Value: Word);

begin

FTxLow := Value;

if hComm < 0 then

exit;

EnableCommNotification(hComm, FWindowHandle, FRxFull, FTxLow);

end;

procedure TComm.SetEvents(Value: TCommEvents);

var

EventMask: Word;

begin

FEvents := Value;

if hComm < 0 then

exit;

EventMask := 0;

if tceBreak in FEvents then

inc(EventMask, EV_BREAK);

if tceCts in FEvents then

inc(EventMask, EV_CTS);

if tceCtss in FEvents then

inc(EventMask, EV_CTSS);

if tceDsr in FEvents then

inc(EventMask, EV_DSR);

if tceErr in FEvents then

inc(EventMask, EV_ERR);

if tcePErr in FEvents then

inc(EventMask, EV_PERR);

if tceRing in FEvents then

inc(EventMask, EV_RING);

if tceRlsd in FEvents then

inc(EventMask, EV_RLSD);

if tceRlsds in FEvents then

inc(EventMask, EV_RLSDS);

if tceRxChar in FEvents then

inc(EventMask, EV_RXCHAR);

if tceRxFlag in FEvents then

inc(EventMask, EV_RXFLAG);

if tceTxEmpty in FEvents then

inc(EventMask, EV_TXEMPTY);

SetCommEventMask(hComm, EventMask);

end;

procedure TComm.WndProc(var Msg: TMessage);

begin

with Msg do

begin

if Msg = WM_COMMNOTIFY then

begin

case lParamLo of

CN_EVENT: DoEvent;

CN_RECEIVE: DoReceive;

CN_TRANSMIT: DoTransmit;

end;

end

else

Result := DefWindowProc(FWindowHandle, Msg, wParam, lParam);

end;

end;

procedure TComm.DoEvent;

var

CommEvent: TCommEvents;

EventMask: Word;

begin

if (hComm < 0) or not Assigned(FOnEvent) then

exit;

EventMask := GetCommEventMask(hComm, Integer($FFFF));

CommEvent := [];

if (tceBreak in Events) and (EventMask and EV_BREAK 0) then

CommEvent := CommEvent [tceBreak];

if (tceCts in Events) and (EventMask and EV_CTS 0) then

CommEvent := CommEvent [tceCts];

if (tceCtss in Events) and (EventMask and EV_CTSS 0) then

CommEvent := CommEvent [tceCtss];

if (tceDsr in Events) and (EventMask and EV_DSR 0) then

CommEvent := CommEvent [tceDsr];

if (tceErr in Events) and (EventMask and EV_ERR 0) then

CommEvent := CommEvent [tceErr];

if (tcePErr in Events) and (EventMask and EV_PERR 0) then

CommEvent := CommEvent [tcePErr];

if (tceRing in Events) and (EventMask and EV_RING 0) then

CommEvent := CommEvent [tceRing];

if (tceRlsd in Events) and (EventMask and EV_RLSD 0) then

CommEvent := CommEvent [tceRlsd];

if (tceRlsds in Events) and (EventMask and EV_Rlsds 0) then

CommEvent := CommEvent [tceRlsds];

if (tceRxChar in Events) and (EventMask and EV_RXCHAR 0) then

CommEvent := CommEvent [tceRxChar];

if (tceRxFlag in Events) and (EventMask and EV_RXFLAG 0) then

CommEvent := CommEvent [tceRxFlag];

if (tceTxEmpty in Events) and (EventMask and EV_TXEMPTY 0) then

CommEvent := CommEvent [tceTxEmpty];

FOnEvent(Self, CommEvent);

end;

procedure TComm.DoReceive;

var

Stat: TComStat;

begin

if (hComm < 0) or not Assigned(FOnReceive) then

exit;

GetCommError(hComm, Stat);

FOnReceive(Self, Stat.cbInQue);

GetCommError(hComm, Stat);

end;

procedure TComm.DoTransmit;

var

Stat: TComStat;

begin

if (hComm < 0) or not Assigned(FOnTransmit) then

exit;

GetCommError(hComm, Stat);

FOnTransmit(Self, Stat.cbOutQue);

end;

procedure TComm.Loaded;

begin

inherited Loaded;

HasBeenLoaded := True;

SetPort(FPort);

end;

constructor TComm.Create(AOwner: TComponent);

begin

inherited Create(AOwner);

FWindowHandle := AllocateHWnd(WndProc);

HasBeenLoaded := False;

Error := False;

FPort := PortDefault;

FBaudRate := BaudRateDefault;

FParity := ParityDefault;

FDataBits := DataBitsDefault;

FStopBits := StopBitsDefault;

FWriteBufferSize := WriteBufferSizeDefault;

FReadBufferSize := ReadBufferSizeDefault;

FRxFull := RxFullDefault;

FTxLow := TxLowDefault;

FEvents := EventsDefault;

hComm := -1;

end;

destructor TComm.Destroy;

begin

DeallocatehWnd(FWindowHandle);

if hComm >= 0 then

CloseComm(hComm);

inherited Destroy;

end;

procedure TComm.Write(Data: PChar; Len: Word);

begin

if hComm < 0 then

exit;

if WriteComm(hComm, Data, Len) < 0 then

Error := True;

GetCommEventMask(hComm, Integer($FFFF));

end;

procedure TComm.Read(Data: PChar; Len: Word);

begin

if hComm < 0 then

exit;

if ReadComm(hComm, Data, Len) < 0 then

Error := True;

GetCommEventMask(hComm, Integer($FFFF));

end;

function TComm.IsError: Boolean;

begin

IsError := Error;

Error := False;

end;

procedure Register;

begin

RegisterComponents('Additional', [TComm]);

end;

end.

[cc lang="delphi"] 

Файл в корзину

MS Windows: Корзина должна быть чиста как совесть!

Не забудьте добавить ShellAPI в группу uses.

А это сама функция, которая выполняет всю работу:

function RecycleFile(sFileName: string): Boolean;

var

FOS: TSHFileOpStruct;

begin

FillChar(FOS, SizeOf(FOS), 0);

with FOS do

begin

wFunc := FO_DELETE; { так же можно использовать FO_COPY.

pFrom := PChar(sFileName);

pTo := { только для FO_COPY }


fFlags := FOF_ALLOWUNDO; { Так как мы хотим послать файл в корзину }

end;

// Отправляем файл

Result := (SHFileOperation(FOS) = 0);

end;

// Пример вызова функции:

RecycleFile('E:\Test.exe' #0);

// либо, если изменить строку

// pFrom:=PChar(sFileName #0); ,

// то можно вызывать проще:

RecycleFile(Filename);

Форматирование диска в Win32

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

...

implementation

...

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

function IsDiskInDrive(Drive: string): Boolean;

var

ErrMode: Cardinal;

VolName: array[0..255] of Char;

FS: array[0..255] of Char;

MaxComSize: Cardinal;

Flags: Cardinal;

begin

ErrMode := SetErrorMode(SEM_FAILCRITICALERRORS);

try

Result := GetVolumeInformation(PChar(Drive), VolName, SizeOf(VolName), nil,

MaxComSize, Flags, FS, SizeOf(FS));

finally

SetErrorMode(ErrMode);

end;

end;

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

if not IsDiskInDriver('A:') then

raise Exception.Create('А дискеты-то нет :(');

[cc lang="delphi"] 

Проверить, вставлен ли диск

function DiskInDrive(Drive: Char): Boolean;

// Disk can be a floppy, CD-ROM,...

var

ErrorMode: Word;

begin

{ make it upper case }

if Drive in ['a'..'z'] then Dec(Drive, $20);

{ make sure it's a letter }

if not (Drive in ['A'..'Z']) then

raise EConvertError.Create('Not a valid drive ID');

{ turn off critical errors }

ErrorMode := SetErrorMode(SEM_FailCriticalErrors);

try

{ drive 1 = a, 2 = b, 3 = c, etc. }

if DiskSize(Ord(Drive) - $40) = -1 then

Result := False

else

Result := True;

finally

{ Restore old error mode }

SetErrorMode(ErrorMode);

end;

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

if DiskInDrive('a') = False then

ShowMessage('Drive not ready');

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;

затем используем её:

if not IsDriveReady('A') then

ShowMessage('Drive Not Ready')

else

ShowMessage('Drive is Ready');

Получить список дисков и сведения о выбранном диске

unit MainFrm;

interface

uses

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

StdCtrls, FileCtrl;

type

TMainForm = class(TForm)

btnGetDriveTypes: TButton;

lbDrives: TListBox;

lblSectPerClust2: TLabel;

lblBytesPerSector2: TLabel;

lblNumFreeClusters2: TLabel;

lblTotalClusters2: TLabel;

lblSectPerCluster: TLabel;

lblBytesPerSector: TLabel;

lblNumFreeClust: TLabel;

lblTotalClusters: TLabel;

lblFreeSpace2: TLabel;

lblTotalDiskSpace2: TLabel;

lblFreeSpace: TLabel;

lblTotalDiskSpace: TLabel;

procedure btnGetDriveTypesClick(Sender: TObject);

procedure lbDrivesClick(Sender: TObject);

end;

var

MainForm: TMainForm;

implementation

{$R *.DFM}

procedure TMainForm.btnGetDriveTypesClick(Sender: TObject);

var

i: Integer;

C: string;

DType: Integer;

DriveString: string;

begin

{ Loop from A..Z to determine available drives }

for i := 65 to 90 do

begin

// Format a string to represent the root directory.

C := chr(i) ':\';

{ Call the GetDriveType() function which returns an integer

value representing one of the types shown in the case statement

below }


DType := GetDriveType(PChar(C));

{ Based on the drive type returned, format a string to add to

the listbox displaying the various drive types. }


case DType of

0: DriveString := C ' The drive type cannot be determined.';

1: DriveString := C ' The root directory does not exist.';

DRIVE_REMOVABLE: DriveString :=

C ' The drive can be removed from the drive.';

DRIVE_FIXED: DriveString :=

C ' The disk cannot be removed from the drive.';

DRIVE_REMOTE: DriveString :=

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

DRIVE_CDROM: DriveString := C ' The drive is a CD-ROM drive.';

DRIVE_RAMDISK: DriveString := C ' The drive is a RAM disk.';

end;

// Only add drive types that can be determined.

if not ((DType = 0) or (DType = 1)) then

lbDrives.Items.AddObject(DriveString, Pointer(i));

end;

end;

procedure TMainForm.lbDrivesClick(Sender: TObject);

var

RootPath: string; // Holds the drive root path

SectorsPerCluster: DWord; // Sectors per cluster

BytesPerSector: DWord; // Bytes per sector

NumFreeClusters: DWord; // Number of free clusters

TotalClusters: DWord; // Total clusters

DriveByte: Byte; // Drive byte value

FreeSpace: Int64; // Free space on drive

TotalSpace: Int64; // Total drive space.

begin

with lbDrives do

begin

{ Convert the ascii value for the drive letter to a valid drive number:

1 = A, 2 = B, etc. by subtracting 64 from the ascii value. }


DriveByte := Integer(Items.Objects[ItemIndex]) - 64;

{ First create the root path string }

RootPath := chr(Integer(Items.Objects[ItemIndex])) ':\';

{ Call GetDiskFreeSpace to obtain the drive information }

if GetDiskFreeSpace(PChar(RootPath), SectorsPerCluster,

BytesPerSector, NumFreeClusters, TotalClusters) then

begin

{ If this function is successful, then update the labels to

display the disk information. }


lblSectPerCluster.Caption := Format('%.0n', [SectorsPerCluster * 1.0]);

lblBytesPerSector.Caption := Format('%.0n', [BytesPerSector * 1.0]);

lblNumFreeClust.Caption := Format('%.0n', [NumFreeClusters * 1.0]);

lblTotalClusters.Caption := Format('%.0n', [TotalClusters * 1.0]);

// Obtain the available disk space

FreeSpace := DiskFree(DriveByte);

TotalSpace := DiskSize(DriveByte);

lblFreeSpace.Caption := Format('%.0n', [FreeSpace * 1.0]);

{ Calculate the total disk space }

lblTotalDiskSpace.Caption := Format('%.0n', [TotalSpace * 1.0]);

end

else

begin

{ Set labels to display nothing }

lblSectPerCluster.Caption := 'X';

lblBytesPerSector.Caption := 'X';

lblNumFreeClust.Caption := 'X';

lblTotalClusters.Caption := 'X';

lblFreeSpace.Caption := 'X';

lblTotalDiskSpace.Caption := 'X';

ShowMessage('Cannot get disk info');

end;

end;

end;

end.