w2k和NT当然不行了，什么叫安全，这就叫安全，呵呵
unit Comm;
interface
uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls;
type
TCmdMode = (cmStr, cmBytes);
TComm = class(TGraphicControl)
private { Private declarations }
FPort : string;
FBaudRate: Word; { Baudrate at which runing }
FByteSize: Byte; { Number of bits/byte, 4-8 }
FParity: Byte; { 0-4=None,Odd,Even,Mark,Space }
FStopBits: Byte; { 0,1,2 = 1, 1.5, 2 }
FWaitByteNum : word;
FTimeOut : word;
FMode : TCmdMode;
ColorSet : array [0..3] of TColor;
FCmdStr : string; { Communicate-relate varibles }
State : integer;
dcb : TDCB;
CommBeginTime : TDateTime;
Timer1 : TTimer; { NotifyEvents }
FOnDataLoad : TNotifyEvent;
FOnTimeOut : TNotifyEvent;
procedure CommQuery(Sender : TObject);
procedure LoadData;
procedure SendCmd;
procedure SendStrCmd;
procedure SendBytesCmd;
procedure SetByteNum(val : word);
procedure DecodeCmd(str1 : string;
var char1 : array of char);
protected { Protected declarations }
procedure Paint; override;
public { Public declarations }
hCommDev : integer; { Memory Pool }
connected, WaitOn : boolean;
stat : TComStat;
CmdChar : array[0..64] of Char;
SendLen : word;
pool : array [0..2048] of char;
ms : TMemoryStream;
constructor Create(AOwner : TComponent); override;
procedure Connect;
procedure Excute;
function GetData(Offset : word) : Char;
procedure ClearSigns;
procedure Free;
procedure HardWait;
procedure Query;
published { Published declarations }
property BaudRate : word read FBaudRate write FBaudRate;
property Parity : byte read FParity write FParity;
property ByteSize : byte read FByteSize write FByteSize;
property StopBits : byte read FStopBits write FStopBits;
property CmdStr : string read FCmdStr write FCmdStr;
property WaitByteNum : word read FWaitByteNum write SetByteNum;
property Port : string read FPort write FPort;
property TimeOut : word read FTimeOut write FTimeOut;
property OnTimeOut : TNotifyEvent read FOnTimeOut write FOnTimeOut; property OnDataLoad : TNotifyEvent read FOnDataLoad write FOnDataLoad; property OnClick; property ShowHint; property OnMouseDown; property Mode : TCmdMode read FMode write FMode; end; procedure Register; implementation procedure Register; begin RegisterComponents('Samples', [TComm]); end; constructor TComm.Create(AOwner : TComponent); begin inherited Create(AOwner); ControlStyle := ControlStyle + [csFramed]; FPort := 'COM1'; FBaudRate := 9600; FByteSize := 8; FStopBits := 0; FParity := 0; FTimeOut := 7; Width := 20; Height := 20; WaitOn := False; Connected := False; State := 0; Hint := '空闲'; ShowHint := True; ColorSet[0] := clBlue; ColorSet[1] := clYellow; ColorSet[2] := clOlive; ColorSet[3] := clMaroon; { Create Memory Stream } ms := TMemoryStream.Create; ms.SetSize(1); FWaitByteNum := 1; { Create a Timer } Timer1 := TTimer.Create(self); Timer1.Interval := 100;
Timer1.OnTimer := CommQuery;
end;
procedure TComm.Paint;
var
rGraph : TRect;
begin
with Canvas do
begin
rGraph := Rect(1, 1, Width - 1, Height - 1);
Pen.Color := clBlack;
MoveTo(rGraph.Right, rGraph.Top);
LineTo(rGraph.Left, rGraph.Top);
LineTo(rGraph.Left, rGraph.Bottom);
Pen.Color := clWhite;
LineTo(rGraph.Right, rGraph.Bottom);
LineTo(rGraph.Right, rGraph.Top);
Brush.Color := ColorSet[State];
Pen.Color := clSilver;
InflateRect(rGraph, -3, -3);
Ellipse(rGraph.Left, rGraph.Top, rGraph.Right, rGraph.Bottom);
end;
end;
procedure TComm.SetByteNum(val : word);
begin
FWaitByteNum := val;
ms.Clear;
ms.SetSize(val);
end;
procedure TComm.Connect;
var
PortChar : array[0..12] of Char;
Label ret1;
begin
Connected := False; { Initialize the Communication Port }
StrPCopy(PortChar, FPort);
hCommDev := OpenComm(PortChar, 8192, 2048);
if hCommDev < 0 then goto ret1;
GetCommState(hCommDev, dcb);
dcb.BaudRate := FBaudRate;
dcb.ByteSize := FByteSize;
dcb.Parity := FParity;
dcb.StopBits := FStopBits;
if SetCommState( dcb ) < 0 then begin
CloseComm(hCommDev);
goto ret1;
end;
EscapeCommFunction( hCommDev, SETDTR );
Connected := True;
ret1:
end;
procedure TComm.DecodeCmd( str1 : string; var char1 : array of char);
var
i, j : integer;
btstr : string;
bytebegin : boolean;
begin
if str1[1] = '$' then
begin
i := 1; j := 0; btstr := ''; bytebegin := false;
while (i<=Length(str1)) do
begin
case str1 of
'0'..'9', 'a'..'f', 'A'..'F' :
begin
if not bytebegin then bytebegin := true;
btstr := btstr + str1;
end;
' ' : begin
if bytebegin then
begin
btstr := '$'+btstr;
char1[j] := Chr(StrToInt(btstr));
j := j + 1; bytebegin := false; btstr := '';
end;
end;
end;
i := i + 1;
end;
if bytebegin then
begin
btstr := '$'+btstr;
char1[j] := Chr(StrToInt(btstr));
j := j + 1; bytebegin := false; btstr := '';
end;
char1[j] := Chr(0);
SendLen := j;
end
else begin
StrPCopy(Addr(char1), str1);
SendLen := Length(str1);
end;
end;
procedure TComm.SendCmd;
begin
case FMode of
cmStr : SendStrCmd;
cmBytes : SendBytesCmd;
end;
end;
procedure TComm.SendBytesCmd;
begin
State := 1; Hint := FPort+'-等待';
Refresh; WaitOn := False;
if not Connected then Connect;
if Connected then begin
FlushComm(hCommDev, 0);
FlushComm(hCommDev, 1);
FillChar(pool, 32, 0);
WriteComm(hCommDev, CmdChar, SendLen);
CmdStr := '';
FillChar(CmdChar, 32, 0);
WaitOn := True;
CommBeginTime := Now;
end
else begin
State := 3;
Hint := FPort+'-错误';
Invalidate;
end; end;
procedure TComm.SendStrCmd;
begin
DecodeCmd(CmdStr, CmdChar);
State := 1; Hint := FPort+'-等待';
Refresh; WaitOn := False;
if not Connected then Connect;
if Connected then begin
FlushComm(hCommDev, 0);
FlushComm(hCommDev, 1);
FillChar(pool, 32, 0);
WriteComm(hCommDev, CmdChar, SendLen);
CmdStr := '';
FillChar(CmdChar, 32, 0);
WaitOn := True;
CommBeginTime := Now;
end else begin
State := 3; Hint := FPort+'-错误';
Invalidate;
end; end;
procedure TComm.ClearSigns;
begin
ReadComm(hCommDev, pool, stat.cbInQue);
pool[stat.cbInQue] := #0;
if WaitOn then begin
State := 2; Hint := FPort+'-超时';
Refresh; WaitOn := False;
end;
CommBeginTime := Now;
FlushComm(hCommDev, 0);
FlushComm(hCommDev, 1);
end;
procedure TComm.LoadData;
begin
ReadComm(hCommDev, pool, stat.cbInQue);
pool[stat.cbInQue] := #0;
ms.Seek(0,0);
ms.Write(pool, FWaitByteNum);
State := 0; Hint := FPort+'-空闲';
Refresh; WaitOn := False;
end;
procedure TComm.HardWait;
begin
while Connected and WaitOn do begin
Query;
end; end;
procedure TComm.CommQuery(Sender : TObject);
begin
Query;
end;
procedure TComm.Query;
var Hour, Min, Sec, MSec : Word;
begin
if Connected and WaitOn and (FWaitByteNum > 0) then
begin
GetCommError(hCommDev, stat);
if stat.cbInQue >= FWaitByteNum then begin
LoadData;
if Assigned(FOnDataLoad) then FOnDataLoad(self);
end
else begin
DecodeTime(Now-CommBeginTime, Hour, Min, Sec, MSec); { Communication Timeout Falure }
if (Sec > FTimeOut) or((FTimeOut = 0) and (MSec > 500)) then begin
ClearSigns;
if Assigned(FOnTimeOut) then FOnTimeOut(self);
end;
end;
end;
end;
procedure TComm.Excute;
begin
if not WaitOn then SendCmd;
end;
procedure TComm.Free;
begin
if Connected then begin Connected := False; ClearSigns; CloseComm(hCommDev);
end; end;
function TComm.GetData(Offset : word) : Char;
begin
if Offset <= FWaitByteNum then begin Result := pool[Offset];
end; end;
end. --
///////////////////////////////////////////////
procedure TForm1.Button1Click(Sender: TObject);
var
lpszNumeCom : PChar;
dwAccessType : DWORD;
dwCreationType : DWORD;
creationDCB : TDCB;
hPort : THandle;
buffer : array[0..55] of char;
actRead : integer;
begin
{Some initial settings: I am working with COM2 in read/write}
lpszNumeCom := '//./COM2';
dwAccessType := GENERIC_READ or GENERIC_WRITE;
dwCreationType := OPEN_EXISTING;
hPort := CreateFile(lpszNumeCom,dwAccessType,0,Nil,dwCreationType,0,0);
{here I have the handle for the COM port}
try
if hPort <> INVALID_HANDLE_VALUE then
begin
{Settings for COM : 600bauds, 8,E,1}
GetCommState(hport,creationDCB);
creationDCB.BaudRate := 600;
creationDCB.Parity := EVENPARITY;
creationDCB.ByteSize := 8;
creationDCB.StopBits := ONESTOPBIT;
{Settings for the control type, here I am reading from a Proximity
card
reader and use only the RX line}
creationDCB.Flags := creationDCB.Flags + DTR_CONTROL_DISABLE
+ RTS_CONTROL_DISABLE;
if SetCommState(hPort,creationDCB) then
begin
PurgeComm(hPort,PURGE_RXCLEAR);
{Here I actually can read data from COM}
{The next function call will not return until it actually reads
data
from the serial port}
ReadFile(hPort,buffer,56,actRead,nil);
PurgeComm(hPort,PURGE_RXCLEAR);
{in buffer you have data readed from the port}
begin
{Do something usefull with data}
end
end
end;
finally
CloseHandle(hPort);
end;
end;
fUnit: DWORD; { Unit descriptor handle}
fUnitDescriptor: string; { Unit descriptor Pascal string }
fUnitDescriptor := 'COM2';
procedure TRs232.OpenPort(descriptor: PChar);
begin
fUnit := CreateFile(descriptor, GENERIC_READ or GENERIC_WRITE,
0,nil,OPEN_EXISTING,0,0);
end;
function TRs232.GetOpenPortError: BOOLEAN;
var
isOK: BOOLEAN;
Error: DWORD;
begin
isOK:=(fUnit <> INVALID_HANDLE_VALUE); //DWORD(-1)
if not isOK then
begin
Error := GetLastError;
{case fUnit of}
case Error of
IE_BADID: ShowMessage('"' + fUnitDescriptor + '" invalid or unsupported');
IE_BAUDRATE: ShowMessage('"' + fUnitDescriptor + '" baudrate unsupported');
IE_BYTESIZE: ShowMessage('Specified bytesize is invalid');
IE_DEFAULT: ShowMessage('Default parameters are in error');
IE_HARDWARE: ShowMessage('"' + fUnitDescriptor + '" not available');
IE_MEMORY: ShowMessage('"' + fUnitDescriptor + '" - unable to allocate queues');
IE_NOPEN: ShowMessage('"' + fUnitDescriptor + '" is not open');
IE_OPEN: ShowMessage('"' + fUnitDescriptor + '" is already open');
else
{ShowMessage('Note: "' + fUnitDescriptor + '" returned error ' +
IntToStr(Error)); }
end;
end;
Result:=isOK;
end;
function TRs232.Output(lpBuffer: PChar): BOOLEAN;
var
lpBytesSent,nBufferSize: LongWord;
begin
nBufferSize := StrLen(lpBuffer);
Result := WriteFile(fUnit, //handle to file to write to
lpBuffer, // pointer to data to write to file
nBufferSize, // number of bytes to write
lpBytesSent, // pointer to number of bytes written
nil); // pointer to structure needed for overlapped IO
end;
function TRs232.Enter(nBytesToRead: LongWord; lpString: PChar; var
lpBytesRead: LongWord): BOOLEAN;
begin
Result := ReadFile(fUnit,
lpString,
nBytesToRead,
lpBytesRead,
nil);
end;
destructor TRs232.Destroy;
begin
if not CloseHandle(fUnit) then
ShowMessage('Error closing port "' + fUnitDescriptor + '"');
inherited Destroy;
end;
