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

Code:

unit TestRosh;

interface

uses

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

Forms, Dialogs, StdCtrls, ExtCtrls;

type

TForm1 = class(TForm)

Panel1: TPanel;

Label1: TLabel;

PortCombo: TComboBox;

Label2: TLabel;

BaudCombo: TComboBox;

Label3: TLabel;

ByteSizeCombo: TComboBox;

Label4: TLabel;

ParityCombo: TComboBox;

Label5: TLabel;

StopBitsCombo: TComboBox;

Label6: TLabel;

Memo1: TMemo;

Edit1: TEdit;

Button1: TButton;

Memo2: TMemo;

Edit2: TEdit;

Label7: TLabel;

Button2: TButton;

Label8: TLabel;

Edit3: TEdit;

procedure Button1Click(Sender: TObject);

procedure Memo2Change(Sender: TObject);

procedure Memo1Change(Sender: TObject);

procedure FormDestroy(Sender: TObject);

procedure Button2Click(Sender: TObject);

procedure PortComboChange(Sender: TObject);

procedure FormShow(Sender: TObject);

procedure Memo1DblClick(Sender: TObject);

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

uses

Registry;

var

hPort: THandle;

procedure TForm1.Memo1Change(Sender: TObject);

var

i: Integer;

begin

Edit1.Text := '';

for i := 1 to Length(Memo1.Text) do

   Edit1.Text := Edit1.Text + Format('%x', [Ord(Memo1.Text[i])]) + ' '

end;

procedure TForm1.Memo2Change(Sender: TObject);

var

i: Integer;

begin

Edit2.Text := '';

for i := 1 to Length(Memo2.Text) do

   Edit2.Text := Edit2.Text + Format('%x', [Ord(Memo2.Text[i])]) + ' '

end;

procedure TForm1.Button1Click(Sender: TObject);

var

S, D: array[0..127] of Char;

actual_bytes: Integer;

DCB: TDCB;

begin

FillChar(S, 128, #0);

FillChar(D, 128, #0);

DCB.DCBlength := SizeOf(DCB);

if not GetCommState(hPort, DCB) then

begin

   ShowMessage('Can not get port state: ' + IntToStr(GetLastError));

   Exit;

end;

try

   DCB.BaudRate := StrToInt(BaudCombo.Text);

except

   BaudCombo.Text := IntToStr(DCB.BaudRate);

end;

try

   DCB.ByteSize := StrToInt(ByteSizeCombo.Text);

except

   ByteSizeCombo.Text := IntToStr(DCB.ByteSize);

end;

if ParityCombo.ItemIndex > -1 then

   DCB.Parity := ParityCombo.ItemIndex

else

   ParityCombo.ItemIndex := DCB.Parity;

if StopBitsCombo.ItemIndex > -1 then

   DCB.StopBits := StopBitsCombo.ItemIndex

else

   StopBitsCombo.ItemIndex := DCB.StopBits;

if not SetCommState(hPort, DCB) then

begin

   ShowMessage('Can not set new port settings: ' + IntToStr(GetLastError));

   Exit;

end;

PurgeComm(hPort, PURGE_TXABORT or PURGE_RXABORT or PURGE_TXCLEAR or PURGE_RXCLEAR);

StrPCopy(S, Memo1.Text);

if not WriteFile(hPort, S, StrLen(S), actual_bytes, nil) then

begin

   ShowMessage('Can not write to port: ' + IntToStr(GetLastError));

   Exit;

end;

if not ReadFile(hPort, D, StrToInt(Edit3.Text), actual_bytes, nil) then

   ShowMessage('Can not read from port: ' + IntToStr(GetLastError))

else

   ShowMessage('Read ' + IntToStr(actual_bytes) + ' bytes');

Memo2.Text := D;

end;

procedure TForm1.FormDestroy(Sender: TObject);

begin

with TRegistry.Create do

begin

   OpenKey('Shkila', True);

   WriteString('Port', PortCombo.Text);

   WriteString('Baud Rate', BaudCombo.Text);

   WriteString('Byte Size', ByteSizeCombo.Text);

   WriteString('Parity', IntToStr(ParityCombo.ItemIndex));

   WriteString('Stop Bits', IntToStr(StopBitsCombo.ItemIndex));

   Destroy;

end;

if not CloseHandle(hPort) then

begin

   ShowMessage('Can not close port: ' + IntToStr(GetLastError));

   Exit;

end;

end;

procedure TForm1.Button2Click(Sender: TObject);

begin

hPort := CreateFile(PChar(PortCombo.Text),

GENERIC_READ + GENERIC_WRITE,

0,

nil,

OPEN_EXISTING,

FILE_ATTRIBUTE_NORMAL,

0);

if hPort = INVALID_HANDLE_VALUE then

   ShowMessage('Can not open ' + PortCombo.Text + ': ' + IntToStr(GetLastError))

else

   Button2.Hide;

end;

procedure TForm1.PortComboChange(Sender: TObject);

begin

FormDestroy(Sender);

Button2.Show;

end;

procedure TForm1.FormShow(Sender: TObject);

begin

with TRegistry.Create do

begin

   OpenKey('Shkila', True);

   PortCombo.Text := ReadString('Port');

   BaudCombo.Text := ReadString('Baud Rate');

   ByteSizeCombo.Text := ReadString('Byte Size');

   ParityCombo.ItemIndex := StrToInt(ReadString('Parity'));

   StopBitsCombo.ItemIndex := StrToInt(ReadString('Stop Bits'));

   Destroy;

end;

end;

procedure TForm1.Memo1DblClick(Sender: TObject);

begin

Memo1.Lines.Clear;

Memo2.Lines.Clear;

Edit1.Text := '';

Edit2.Text := '';

end;

end.

Code:

unit U_Usb;

interface

uses

Windows, Messages, SysUtils, Classes, Forms;

type

PDevBroadcastHdr  = ^DEV_BROADCAST_HDR;

DEV_BROADCAST_HDR = packed record

   dbch_size: DWORD;

   dbch_devicetype: DWORD;

   dbch_reserved: DWORD;

end;

PDevBroadcastDeviceInterface  = ^DEV_BROADCAST_DEVICEINTERFACE;

DEV_BROADCAST_DEVICEINTERFACE = record

   dbcc_size: DWORD;

   dbcc_devicetype: DWORD;

   dbcc_reserved: DWORD;

   dbcc_classguid: TGUID;

   dbcc_name: short;

end;

const

GUID_DEVINTERFACE_USB_DEVICE: TGUID = '{A5DCBF10-6530-11D2-901F-00C04FB951ED}';

DBT_DEVICEARRIVAL          = $8000;          // system detected a new device

DBT_DEVICEREMOVECOMPLETE   = $8004;          // device is gone

DBT_DEVTYP_DEVICEINTERFACE = $00000005;      // device interface class

type

TComponentUSB = class(TComponent)

private

   FWindowHandle: HWND;

   FOnUSBArrival: TNotifyEvent;

   FOnUSBRemove: TNotifyEvent;

   procedure WndProc(var Msg: TMessage);

   function USBRegister: Boolean;

protected

   procedure WMDeviceChange(var Msg: TMessage); dynamic;

public

   constructor Create(AOwner: TComponent); override;

   destructor Destroy; override;

published

   property OnUSBArrival: TNotifyEvent read FOnUSBArrival write FOnUSBArrival;

   property OnUSBRemove: TNotifyEvent read FOnUSBRemove write FOnUSBRemove;

end;

implementation

constructor TComponentUSB.Create(AOwner: TComponent);

begin

inherited Create(AOwner);

FWindowHandle := AllocateHWnd(WndProc);

USBRegister;

end;

destructor TComponentUSB.Destroy;

begin

DeallocateHWnd(FWindowHandle);

inherited Destroy;

end;

procedure TComponentUSB.WndProc(var Msg: TMessage);

begin

if (Msg.Msg = WM_DEVICECHANGE) then

begin

   try

     WMDeviceChange(Msg);

   except

     Application.HandleException(Self);

   end;

end

else

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

end;

procedure TComponentUSB.WMDeviceChange(var Msg: TMessage);

var

devType: Integer;

Datos: PDevBroadcastHdr;

begin

if (Msg.wParam = DBT_DEVICEARRIVAL) or (Msg.wParam = DBT_DEVICEREMOVECOMPLETE) then

begin

   Datos := PDevBroadcastHdr(Msg.lParam);

   devType := Datos^.dbch_devicetype;

   if devType = DBT_DEVTYP_DEVICEINTERFACE then

   begin // USB Device

     if Msg.wParam = DBT_DEVICEARRIVAL then

     begin

       if Assigned(FOnUSBArrival) then

         FOnUSBArrival(Self);

     end

     else

     begin

       if Assigned(FOnUSBRemove) then

         FOnUSBRemove(Self);

     end;

   end;

end;

end;

function TComponentUSB.USBRegister: Boolean;

var

dbi: DEV_BROADCAST_DEVICEINTERFACE;

Size: Integer;

r: Pointer;

begin

Result := False;

Size := SizeOf(DEV_BROADCAST_DEVICEINTERFACE);

ZeroMemory(@dbi, Size);

dbi.dbcc_size := Size;

dbi.dbcc_devicetype := DBT_DEVTYP_DEVICEINTERFACE;

dbi.dbcc_reserved := 0;

dbi.dbcc_classguid  := GUID_DEVINTERFACE_USB_DEVICE;

dbi.dbcc_name := 0;

r := RegisterDeviceNotification(FWindowHandle, @dbi,

   DEVICE_NOTIFY_WINDOW_HANDLE

   );

if Assigned(r) then Result := True;

end;

end.