COM编程
1. 调用CreateFile创建Comm口的句柄；
fhComm : THandle;
..
fhComm := CreateFile(PChar(strCommName),
GENERIC_READ or GENERIC_WRITE,
0, //Exclusive Access
nil, //No Security Attribute
OPEN_EXISTING,
FILE_FLAG_OVERLAPPED,
0); //Template File
if fhComm = INVALID_HANDLE_VALUE then
//出错处理
其中strCommName是一个string类型的，值如'COM1', 'COM2'等等
2. 调用SetupComm设置Comm通信的发送与接收缓冲区大小;
3. 调用PurgeComm清空发送与接收缓冲区
if not PurgeComm(fhComm, PURGE_RXABORT or PURGE_RXCLEAR or
PURGE_TXABORT or PURGE_TXCLEAR) then
//出错处理
4. 充分使用Overlapped I/O提高效率就要设置读写的TimeOut, 调用例程如下:
cto : TCommTimeOuts;
..
cto.ReadIntervalTimeout := $ffffffff;
cto.ReadTotalTimeoutMultiplier := 0;
cto.ReadTotalTimeoutConstant := 1000; //1 second
cto.WriteTotalTimeoutMultiplier := 2*CBR_9600 div CBR_19200;
cto.WriteTotalTimeoutConstant := 0;
if not SetCommTimeOuts(fhComm, cto) then
//出错处理
5. 设置COMM口的Data Control Block的属性:
dcb : TDCB;
dcbFlag : integer;
..
dcb.DCBlength := SizeOf(TDCB);
if not GetCommState(fhComm, dcb) then
//出错处理
dcb.DCBlength := SizeOf(TDCB);
dcb.BaudRate := nBaud;
dcb.ByteSize := 8;
dcb.Parity := ODDPARITY;
dcb.StopBits := ONESTOPBIT;
dcb.XonChar := Chr($11); //Ctrl_Q
dcb.XoffChar := Chr($13); //Ctrl_S
dcb.ErrorChar := Chr(0);
dcb.XonLim := 100;
dcb.XoffLim := 100;
dcbFlag := 1; //Binary must be True
dcbFlag := dcbFlag or 2; //Parity Check True
dcbFlag := dcbFlag or 4; //FOutxCtsFlowCtrl
dcbFlag := dcbFlag or 8; //FOutxDsrFlowCtrl
dcbFlag := dcbFlag or $10; //DsrEnable
// dcbFlag := dcbFlag or $20; //DtrHandShake
dcbFlag := dcbFlag or $1000; //RtsEnable
// dcbFlag := dcbFlag or $800; //Ignore NULL Char
dcb.Flags := dcbFlag;
if not SetCommState(fhComm, dcb) then
//出错处理
6. 使RTS和DTR设置为高电平，这是RS232通信一般需要的
if not EscapeCommFunction(fhComm, SETDTR) then
//出错处理
if not EscapeCommFunction(fhComm, SETRTS) then
//出错处理
7. 设置好读和写的Overlapped i/o对应的结构体:
readOl, readOpOl: TOverLapped;
writeOl : TOverLapped;
..
FillChar(writeOl, SizeOf(writeOl), 0);
writeOl.hEvent := CreateEvent(nil, True, False, nil);
FillChar(readOl, SizeOf(readOl), 0);
readOl.hEvent := CreateEvent(nil, True, False, nil);
FillChar(readOpOl, SizeOf(readOpOl), 0);
readOpOl.hEvent := CreateEvent(nil, True, False, nil);
其中readOpOl是用来进行读操作事件响应的overlapped i/o操作的
overlapped 结构体
8. 读操作:
SetCommMask(fhComm, EV_RXCHAR);
用来表示我们对EV_RXCHAR事件感兴趣，有Char来到的时候系统会通知我们
dwEventMask := 0;
WaitCommEvent(fhComm, dwEventMask, @readOpOl);
上面这两句表示我们要等待设置好的事件的发生（上面一句我们已经设置了
EV_RXCHAR事件),由于有一个readOpOl，表示我们进行的是overlapped等待，不会
被这个等待堵塞住
然后下面就要调用WaitForSingleObject或者是WaitForMultiObjects来等待
设置好的Event的发生了(代码省略,至少你要自己看看Event和WaitFor???Object
函数的帮助)
下面你可以调用ClearCommError来得到Error,然后得到Comm口接收缓冲区里面
数据的大小:
commStat : TComStat;
..
ClearCommError(fhComm, dwErr, @commStat);
if commStat.cbInQue >= 0 then
...
再下面你要调用ReadFile来读取数据:
pchToRecv : LPSTR;
byteToRecv : array [0..nBuffLen-1] of Char;
..
pchToRecv := LPSTR(LocalAlloc(LPTR, nBuffLen+1));
if not ReadFile(fhComm, pchToRecv^, dwLength, dwLength, @readOl) then
begin
if GetLastError=ERROR_IO_PENDING then
begin
while not GetOverLappedResult(fhComm, readOl, dwLength, TRUE) do
begin
dwErr := GetLastError;
if dwErr=ERROR_IO_INCOMPLETE then
continue
else begin
ClearCommError(fhComm, dwError, @commStat);
fStrErr := 'OS Synchronization Error!';
end;
end; //end while
ResetEvent(readOl.hEvent);
end // end if GetLastError...
else begin
ClearCommError(fhComm, dwError, @commStat);
fStrErr := 'OS Synchronization Error!';
end;
end; //end if dwLength>0 , end if not ReadFile...
Result := dwLength;
...
CopyMemory(@byteToRecv, pchToRecv, nBuffLen);
...
LocalFree(THandle(pchToRecv));
在上面我用了一个LPSTR来接收数据，然后还使用了LocalAlloc, LocalFree
等这样的函数，这似乎是唯一的方法，直接使用array of char好像会出问题。
另外上面的读取部分是我写在一个函数里面的，所以还有一个Result返回读
取的数据的多少，另外还有由于使用的是overlapped i/o,所以如果得到的错误
是i/o pending的错误是正常的。
9. 写操作:
ClearCommError(fhComm, dwErr, @commStat);
if commStat.cbOutQue>(2*nBuffLen + nBuffLen div 2) then
//我自己判断发送缓冲区大小的阈值，如果大了就下次发送
bWriteFile := WriteFile(fhComm, byteToSend, nToWrite, dwLength, @writeOl);
if not bWriteFile then
begin
dwErr := GetLastError;
if dwErr = ERROR_IO_PENDING then
begin
while not GetOverLappedResult(fhComm, writeOl, dwLength, TRUE) do
begin
dwErr := GetLastError;
if dwErr = ERROR_IO_INCOMPLETE then
continue
else begin
ClearCommError(fhComm, dwError, @commStat);
fStrErr := 'OS synchronization error!';
end;
end; //end while
//If you want to check error, call GetCommModemStatus
ResetEvent(writeOl.hEvent);
end // end if GetLastError=...
else begin
ClearCommError(fhComm, dwError, @commStat);
fStrErr := 'OS synchronization error!';
end;
end; //end if not bWriteFile
Result := dwLength;
10. 关闭Comm口
SetCommBreak(fhComm);
//Break to notify the peer interrupt to end the transfer
EscapeCommFunction(fhComm, CLRDTR);
EscapeCommFunction(fhComm, CLRRTS);
PurgeComm(fhComm, PURGE_RXCLEAR or PURGE_RXABORT or
PURGE_TXCLEAR or PURGE_TXABORT);
SetCommMask(fhComm, 0);
CloseHandle(fhComm);
CloseHandle(writeOl.hEvent);
CloseHandle(readOl.hEvent);
CloseHandle(readOpOl.hEvent);
11.另外你还需要用的函数可能是
GetCommModemStatus,至于用法么，xixi, 自己查吧。
----------------------------------------
发信人: erain (红花会主), 信区: Delphi
标 题: 串口传输的API编程已经基本可用了
发信站: BBS 水木清华站 (Fri Feb 18 11:22:26 2000) WWW-POST
unit U_Main;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs
,
StdCtrls, ExtCtrls, Math, fileCtrl;
const
nBuffLen = 1024;
MEMOMAX = 100;
type
TCommDaemonThd = class(TThread)
private
strFile, strInfo : string;
mOut : TMemo;
hComm : THandle;
pchToRecv : LPSTR;
function ReadComm(dwLength : DWORD): integer;
procedure ShowStatus;
protected
procedure Execute;override;
public
hFile : File;
bClosed : Boolean;
constructor Create(memo: TMemo; comm: THandle; sFile: string);
end;
TWriteCommThd = class(TThread)
private
byteToSend : array[0..nBuffLen-1] of Char;
pchToSend : LPSTR;
bEndSend : Boolean;
strFile : string;
mOut : TMemo;
hComm : THandle;
dwError : DWORD;
nCount : integer;
strInfo : string;
function WriteComm(nToWrite: integer): integer;
procedure ShowStatus;
procedure CleanUp;
protected
procedure Execute;override;
public
hFile : File;
constructor Create(memo: TMemo; comm: THandle);
end;
TfrmMain = class(TForm)
btnConnect: TButton;
btndisConnect: TButton;
radioComm: TRadioGroup;
Label1: TLabel;
eSendFile: TEdit;
eRecvFile: TEdit;
Label2: TLabel;
btnSend: TButton;
mStatus: TMemo;
Label3: TLabel;
dlgOpen: TOpenDialog;
btnStop: TButton;
procedure eSendFileDblClick(Sender: TObject);
procedure frmMainCreate(Sender: TObject);
procedure frmMainDestroy(Sender: TObject);
procedure btnConnectClick(Sender: TObject);
procedure btndisConnectClick(Sender: TObject);
procedure btnSendClick(Sender: TObject);
procedure btnStopClick(Sender: TObject);
private
thdDaemon : TCommDaemonThd;
thdWrite : TWriteCommThd;
hComm : THandle;
procedure EnableCtrl(bEnable : Boolean);
public
strCommName : string;
bConnected : Boolean;
writeOl, readOl : TOverLapped;
end;
var
frmMain: TfrmMain;
implementation
{$R *.DFM}
procedure TfrmMain.eSendFileDblClick(Sender: TObject);
begin
dlgOpen.Title := 'Select Send File';
if dlgOpen.Execute then
eSendFile.Text := dlgOpen.FileName;
end;
procedure TfrmMain.frmMainCreate(Sender: TObject);
begin
bConnected := False;
writeOl.Offset := 0;
writeOl.OffsetHigh := 0;
writeOl.hEvent := CreateEvent(nil, True, False, nil);
readOl.Offset := 0;
readOl.OffsetHigh := 0;
readOl.hEvent := CreateEvent(nil, True, False, nil);
end;
procedure TfrmMain.frmMainDestroy(Sender: TObject);
begin
if bConnected then
btndisConnectClick(Sender);
CloseHandle(writeOl.hEvent);
CloseHandle(readOl.hEvent);
end;
procedure TfrmMain.btnConnectClick(Sender: TObject);
var
cto : TCommTimeOuts;
dcb : TDCB;
dcbFlag : integer;
begin
if not FileExists(eSendFile.Text) then
begin
if mStatus.Lines.Count=MEMOMAX then
mStatus.Lines.Delete(0);
mStatus.Lines.Append('File not Exists or Directory not Exists!');
Beep;
Exit;
end;
if radioComm.ItemIndex=0 then
strCommName := 'COM1'
else
strCommName := 'COM2';
try
hComm := CreateFile(PChar(strCommName),
GENERIC_READ or GENERIC_WRITE,
0, //Exclusive Access
nil, //No Security Attribute
OPEN_EXISTING,
FILE_FLAG_OVERLAPPED,
0); //Template File
if hComm=INVALID_HANDLE_VALUE then
raise Exception.Create(strCommName+' Open Failed!');
except
if mStatus.Lines.Count=MEMOMAX then
mStatus.Lines.Delete(0);
mStatus.Lines.Append(strCommName+' Open Failed!');
Beep;
Exit;
end;
try
if not SetCommMask(hComm, EV_RXCHAR) then
raise Exception.Create(strCommName+' Setup Step 1 Failed!');
if not SetupComm(hComm, 4*nBuffLen, 4*nBuffLen) then
raise Exception.Create(strCommName+' Setup Step 1 Failed!');
if not PurgeComm(hComm, PURGE_RXABORT or PURGE_RXCLEAR or
PURGE_TXABORT or PURGE_TXCLEAR) then
raise Exception.Create(strCommName+' Setup Step 1 Failed!');
cto.ReadIntervalTimeout := $ffffffff;
cto.ReadTotalTimeoutMultiplier := 0;
cto.ReadTotalTimeoutConstant := 1000; //1 second
cto.WriteTotalTimeoutMultiplier := 2*CBR_9600 div CBR_19200;
cto.WriteTotalTimeoutConstant := 0;
if not SetCommTimeOuts(hComm, cto) then
raise Exception.Create(strCommName+' Setup Step 1 Failed!');
except
CloseHandle(hComm);
if mStatus.Lines.Count=MEMOMAX then
mStatus.Lines.Delete(0);
mStatus.Lines.Append(strCommName+' Setup Step 1 Failed!');
Beep;
Exit;
end;
try
dcb.DCBlength := SizeOf(TDCB);
if not GetCommState(hComm, dcb) then
raise Exception.Create(strCommName+' Setup Step 2 Failed!');
dcb.DCBlength := SizeOf(TDCB);
dcb.BaudRate := CBR_38400;
dcb.ByteSize := 8;
dcb.Parity := NOPARITY;
dcb.StopBits := ONESTOPBIT;
dcb.XonChar := Chr($11); //Ctrl_Q
dcb.XoffChar := Chr($13); //Ctrl_S
dcb.ErrorChar := Chr(0);
dcb.XonLim := 100;
dcb.XoffLim := 100;
dcbFlag := 1; //Binary must be True
dcbFlag := dcbFlag or 2; //Parity Check True
dcbFlag := dcbFlag or 4; //FOutxCtsFlowCtrl
dcbFlag := dcbFlag or 8; //FOutxDsrFlowCtrl
dcbFlag := dcbFlag or $20; //DtrHandShake
dcbFlag := dcbFlag or $1000; //RtsEnable
// dcbFlag := dcbFlag or $800; //Ignore NULL Char
dcb.Flags := dcbFlag;
if not SetCommState(hComm, dcb) then
raise Exception.Create(strCommName+' Setup Step 2 Failed!');
bConnected := True;
except
CloseHandle(hComm);
if mStatus.Lines.Count=MEMOMAX then
mStatus.Lines.Delete(0);
mStatus.Lines.Append(strCommName+' Setup Step 2 Failed!');
Beep;
Exit;
end;
EscapeCommFunction(hComm, SETDTR);
EscapeCommFunction(hComm, SETRTS);
thdDaemon := TCommDaemonThd.Create(mStatus, hComm, eRecvFile.Text);
EnableCtrl(False);
if mStatus.Lines.Count=MEMOMAx then
mStatus.Lines.Delete(0);
mStatus.Lines.Append('Connection setup successfully!');
end;
procedure TCommDaemonThd.Execute;
var
dwEventMask, dwErr, dwLength: DWORD;
commStat : TComStat;
nTotal, nLength, nLen : integer;
bContinue : Boolean;
begin
bContinue := True;
nTotal := 0;
SetCommMask(hComm, EV_RXCHAR);
SetLength(strInfo, 0);
AssignFile(hFile, strFile);
ReWrite(hFile, 1);
bClosed := False;
while bContinue do
begin
dwEventMask := 0;
WaitCommEvent(hComm, dwEventMask, nil);
if ( (dwEventMask and EV_RXCHAR)=EV_RXCHAR ) then //Char Received
repeat
ClearCommError(hComm, dwErr, @commStat);
dwLength := min( nBuffLen, commStat.cbInque);
pchToRecv := LPSTR(LocalAlloc(LPTR, dwLength+1));
nLength := ReadComm(dwLength);
nTotal := nTotal + nLength;
if nLength<>0 then
begin
BlockWrite(hFile, pchToRecv^, nLength, nLen);
strInfo := IntToStr(nTotal)+' bytes successfully received!';
Synchronize(ShowStatus);
end;
LocalFree(THandle(pchToRecv));
until nLength=0;
PurgeComm(hComm, PURGE_RXCLEAR or PURGE_RXABORT);
end;
CloseFile(hFile);
bClosed := True;
end;
constructor TCommDaemonThd.Create(memo: TMemo; comm: THandle; sFile: strin
g);
begin
strFile := sFile;
mOut := memo;
hComm := comm;
bClosed := True;
FreeOnTerminate := True;
inherited Create(False);
end;
procedure TCommDaemonThd.ShowStatus;
begin
if mOut.Lines.Count=MEMOMAX then
mOut.Lines.Delete(0);
mOut.Lines.Append(strInfo);
end;
function TCommDaemonThd.ReadComm(dwLength : DWORD):integer;
var
dwErr, dwError : DWORD;
commStat : TComStat;
begin
if dwLength>0 then
if not ReadFile(hComm, pchToRecv^, dwLength, dwLength,
@frmMain.readOl)
then
begin
if GetLastError=ERROR_IO_PENDING then
begin
while not GetOverLappedResult(hComm, frmMain.readOl, dwLength, TRUE)
do
begin
dwErr := GetLastError;
if dwErr=ERROR_IO_INCOMPLETE then
continue
else begin
ClearCommError(hComm, dwError, @commStat);
strInfo := 'Error: '+IntToStr(dwError);
Synchronize(ShowStatus);
end;
end; //end while
end // end if GetLastError...
else begin
ClearCommError(hComm, dwError, @commStat);
strInfo := 'Error: '+IntToStr(dwError);
Synchronize(ShowStatus);
end;
end; //end if dwLength>0 , end if not ReadFile...
Result := dwLength;
end;
procedure TfrmMain.btndisConnectClick(Sender: TObject);
begin
thdDaemon.Suspend;
if not thdDaemon.bClosed then
CloseFile(thdDaemon.hFile);
thdDaemon.Free;
if btnStop.Enabled then
begin
thdWrite.Suspend;
CloseFile(thdWrite.hFile);
thdWrite.Free;
btnSend.Enabled := True;
btnStop.Enabled := False;
end;
EscapeCommFunction(hComm, CLRDTR);
EscapeCommFunction(hComm, CLRRTS);
PurgeComm(hComm, PURGE_RXCLEAR or PURGE_RXABORT or
PURGE_TXCLEAR or PURGE_TXABORT);
bConnected := False;
SetCommMask(hComm, 0);
CloseHandle(hComm);
EnableCtrl(True);
if mStatus.Lines.Count=MEMOMAx then
mStatus.Lines.Delete(0);
mStatus.Lines.Append('Disconnected successfully!');
end;
procedure TfrmMain.EnableCtrl(bEnable : Boolean);
begin
btnConnect.Enabled := bEnable;
btnSend.Enabled := not bEnable;
btndisConnect.Enabled := not bEnable;
radioComm.Enabled := bEnable;
eRecvFile.Enabled := bEnable;
end;
procedure TWriteCommThd.Execute;
var
nStart, nEnd, nLen, nByteToWrite : integer;
begin
nStart := GetTickCount;
nCount := 0;
strFile := frmMain.eSendFile.Text;
AssignFile(hFile, strFile);
ReSet(hFile, 1);
nLen := FileSize(hFile);
while not bEndSend do
begin
BlockRead(hFile, byteToSend, nBuffLen, nByteToWrite);
pchToSend := byteToSend;
PurgeComm(hComm, PURGE_TXCLEAR or PURGE_TXABORT);
nCount := nCount + WriteComm(nByteToWrite);
if nCount>= nLen then
bEndSend := True;
end;
nEnd := GetTickCount-nStart;
Synchronize(CleanUp);
CloseFile(hFile);
strInfo := 'Transfer completed: '+IntToStr(nLen)+' bytes transfered!';
Synchronize(ShowStatus);
strInfo := 'The transfer has taken '+IntToStr(nEnd)+' milliseconds';
Synchronize(ShowStatus);
end;
constructor TWriteCommThd.Create(memo: TMemo; comm: THandle);
begin
bEndSend := False;
hComm := comm;
mOut := memo;
FreeOnTerminate := True;
inherited Create(False);
end;
function TWriteCommThd.WriteComm(nToWrite:integer): integer;
var
bWriteFile : Boolean;
dwLength, dwErr: DWORD;
commStat : TComStat;
begin
bWriteFile := WriteFile(hComm, pchToSend^, nToWrite, dwLength,
@frmMain.
writeOl);
if not bWriteFile then
begin
dwErr := GetLastError;
if dwErr=ERROR_IO_PENDING then
begin
while not GetOverLappedResult(hComm, frmMain.writeOl, dwLength, TRUE
) do
begin
dwErr := GetLastError;
if dwErr=ERROR_IO_INCOMPLETE then
continue
else begin
ClearCommError(hComm, dwError, @commStat);
strInfo := 'Error: '+IntToStr(dwError);
Synchronize(ShowStatus);
end;
end; //end while
//If want to check error, call GetCommModemStatus
end // end if GetLastError=...
else begin
ClearCommError(hComm, dwError, @commStat);
strInfo := 'Error: '+IntToStr(dwError);
Synchronize(ShowStatus);
end;
end; //end if not bWriteFile
Result := dwLength;
end;
procedure TfrmMain.btnSendClick(Sender: TObject);
begin
thdWrite := TWriteCommThd.Create(mStatus, hComm);
btnSend.Enabled := False;
btnStop.Enabled := True;
if mStatus.Lines.Count=MEMOMAx then
mStatus.Lines.Delete(0);
mStatus.Lines.Append('Sending file...');
end;
procedure TfrmMain.btnStopClick(Sender: TObject);
begin
thdWrite.Suspend;
CloseFile(thdWrite.hFile);
thdWrite.Free;
btnSend.Enabled := True;
btnStop.Enabled := False;
if mStatus.Lines.Count=MEMOMAx then
mStatus.Lines.Delete(0);
mStatus.Lines.Append('File transfer interrupted!');
end;
procedure TWriteCommThd.ShowStatus;
begin
if mOut.Lines.Count=MEMOMAX then
mOut.Lines.Delete(0);
mOut.Lines.Append(strInfo);
end;
procedure TWriteCommThd.CleanUp;
begin
frmMain.btnSend.Enabled := True;
frmMain.btnStop.Enabled := False;
end;
end.