I have returned to this project and I made several improvements. I am also using it now with a different serial device that answers a "?" with a set of ID strings, and all others with "Error". It works OK but if I close the COM port in the program or by cutting power to the device, the program hangs up. It seems to be stuck in the following:
function TBlockSerial.CanEvent(Event: dword; Timeout: integer): boolean;
var
ex: DWord;
y: Integer;
Overlapped: TOverlapped;
begin
FillChar(Overlapped, Sizeof(Overlapped), 0);
Overlapped.hEvent := CreateEvent(nil, True, False, nil);
try
SetCommMask(FHandle, Event);
SetSynaError(sOK);
if (Event = EV_RXCHAR) and (Waitingdata > 0) then
Result := True
else
begin
y := 0;
if not WaitCommEvent(FHandle, ex, @Overlapped) then
y := GetLastError;
if y = ERROR_IO_PENDING then
begin
//timedout
WaitForSingleObject(Overlapped.hEvent, Timeout);
SetCommMask(FHandle, 0);
GetOverlappedResult(FHandle, Overlapped, DWord(y), True);
end;
Result := (ex and Event) = Event;
end;
finally
SetCommMask(FHandle, 0);
CloseHandle(Overlapped.hEvent);
end;
end;
Here is my code:
const
Ctrl_A = 01;
Ctrl_D = 04;
Ctrl_T = 20;
Ctrl_Z = 26;
LF = 10;
CR = 13;
MAXBUFF = 5000;
var
fmSerialTest: TfmSerialTest;
CharCount: longint;
CommBuffer: Array[0..MAXBUFF+1] of byte;
CommBufferPtr, LastCommBufferPtr: longint;
Test: boolean = FALSE;
implementation
{$R *.lfm}
{ TfmSerialTest }
procedure TfmSerialTest.Button1Click(Sender: TObject);
begin
LazSerial1.ShowSetupDialog;
LazSerial1.Open;
end;
procedure TfmSerialTest.Button2Click(Sender: TObject);
begin
LazSerial1.Close;
end;
procedure TfmSerialTest.btStartClick(Sender: TObject);
begin
Test := FALSE;
LazSerial1.SynSer.SendByte(Ctrl_A);
end;
procedure TfmSerialTest.btStopClick(Sender: TObject);
begin
LazSerial1.SynSer.SendByte(Ctrl_D);
end;
procedure TfmSerialTest.btTestClick(Sender: TObject);
begin
Test := TRUE;
LazSerial1.SynSer.SendByte(Ctrl_T);
end;
procedure TfmSerialTest.FormCreate(Sender: TObject);
begin
LazSerial1.BaudRate := br_57600;
CommBufferPtr := 0;
LastCommBufferPtr := 0;
try
CharCount := 0;
LazSerial1.Device:='COM21';
LazSerial1.Open;
LazSerial1.SynSer.SendByte(Ctrl_D);
except
MessageDlg('Error','Error opening default port',mtConfirmation,[mbOK],'');
end;
end;
procedure TfmSerialTest.LazSerial1RxData(Sender: TObject);
var RecvData: byte;
begin
RecvData := LazSerial1.synser.RecvByte(0);
if (not Test) or (RecvData > CR) then begin
CommBuffer[CommBufferPtr] := RecvData;
if CommBufferPtr < MAXBUFF then
inc( CommBufferPtr )
else
CommBufferPtr := 0;
inc(CharCount);
end;
end;
procedure TfmSerialTest.Memo1KeyPress(Sender: TObject; var Key: char);
begin
LazSerial1.SynSer.SendByte(byte(Key));
end;
procedure TfmSerialTest.Timer1Timer(Sender: TObject);
var BufferPtr: longint;
begin
Memo1.SetFocus;
eCharCount.Text:= IntToStr(CharCount);
BufferPtr := LastCommBufferPtr;
while BufferPtr <> CommBufferPtr do begin
Memo1.Lines.Text := Memo1.Lines.Text + char(CommBuffer[BufferPtr]); //strData;
Memo1.SelStart:= Length(Memo1.Lines.Text);
if BufferPtr < MAXBUFF then
inc(BufferPtr)
else
BufferPtr := 0;
end;
LastCommBufferPtr := BufferPtr;
end;
I thought the "LazSerial1.Close;" would work, but the button for "Open" does not enter the OnClick handler:
LazSerial1.ShowSetupDialog;
LazSerial1.Open;
Actually, after a long time (several minutes), it does work. Perhaps there is a very long timeout?
[edit]If there is no communication activity, the open and close buttons are responsive. But once communication occurs, the buttons need to be clicked several times before they respond. It's as if the button click message gets ignored until a brief window opens so the system can respond.
I can see that even without any activity on the COM port, the following line is repeatedly executed:
WaitForSingleObject(Overlapped.hEvent, Timeout);
So that means GetLastError = ERROR_IO_PENDING.