一个Delphi下的串口类

ysoni · 发表于 2016-8-29 22:07:30

自己用API写的串口类，　希望能帮到需要的人

unit SerialPort;

interface

{$I Ver.inc}

uses
  Classes, Windows, SysUtils, Variants, Registry, SiTimer;

const
  SER_SUCCESS             = 0;       ///< No error
  SER_ERR_CLASS          = $1100; ///< Serial error class
  SER_INVALID_PARAMETER    = $1101; ///< Parameter invalid or not supported
  SER_API_ERROR          = $1102; ///< Underlaying API returns an error
  SER_PORT_NOT_FOUND       = $1103; ///< Serial port not found
  SER_ALREADY_OPEN       = $1104; ///< Serial port already open
  SER_NOT_OPEN             = $1105; ///< Port not opened
  SER_TIME_OUT             = $1106; ///< Operation timed out
  SER_LINE_ERROR          = $1107; ///< RS232 line error
  SER_UNSUPPORTED_OPERATION = $1108; /// Operation not supported in current configuration
  SER_PORT_NO_ACCESS       = $1109; ///< No access rights for port (Try as root)

  SER_DATABITS_4 = 4;  ///< 4 data bits
  SER_DATABITS_5 = 5;  ///< 5 data bits
  SER_DATABITS_6 = 6;  ///< 6 data bits
  SER_DATABITS_7 = 7;  ///< 7 data bits
  SER_DATABITS_8 = 8;  ///< 8 data bits

  SER_STOPBITS_1  = 0;  ///< 1 stop bit
  SER_STOPBITS_15 = 1;  ///< 1.5 stop bit
  SER_STOPBITS_2  = 2;  ///< 2 stop bits

  SER_PARITY_NONE  = 0;  ///< No parity
  SER_PARITY_ODD = 1;  ///< Odd parity
  SER_PARITY_EVEN  = 2;  ///< Even parity
  SER_PARITY_MARK  = 3;  ///< Mark parity
  SER_PARITY_SPACE = 4;  ///< Space parity

  SER_HANDSHAKE_NONE    = 0; ///< No handshake
  SER_HANDSHAKE_XONXOFF = 1; ///< Xon/Xoff software handshake
  SER_HANDSHAKE_HARDWARE  = 2; ///< hardware handshake

type
  TSerialPort = class(TComponent)
  private
FHandle: THandle;
commTimeOutBlock: TCommTimeouts;
savedCommTimeOutBlock: TCommTimeouts;
savedDevCtrlBlock: TDCB;

FPort: Integer;
FBaudRate: DWORD;
FDataBits: Integer;
FParity: Integer;
FStopBits: Integer;
FFlowControl: Integer;

FOverlapped: Boolean;
   ovInternal: TOverlapped;

timeoutTimer: TSiTimer;

procedure SetPort(Value: Integer);
procedure SetBaudRate(Value: DWORD);
procedure SetDataBits(Value: Integer);
procedure SetParity(Value: Integer);
procedure SetStopBits(Value: Integer);
procedure SetFlowControl(Value: Integer);
  protected
procedure SyncSend(bufPtr: array of Byte; len: DWORD; timeout: DWORD);
function SyncReceive(out bufPtr: array of Byte; len: DWORD; timeout: DWORD): Integer;
function SyncReceiveByte(out bufPtr: Byte; timeout: DWORD): Integer;
procedure AsyncSend(bufPtr: array of Byte; len: DWORD; timeout: DWORD);
function AsyncReceive(out bufPtr: array of Byte; len: DWORD; timeout: DWORD): Integer;
function AsyncReceiveByte(out bufPtr: Byte; timeout: DWORD): Integer;
  public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function Open(port: Integer; overlapped: Boolean): Integer;
procedure Close;
function Config(baudRate: DWORD; dataBits: Integer; stopBits: Integer;
                  parity: Integer; flowControl: Integer): Integer;
function SetBufferSizes(input: DWORD; output: DWORD): Integer;

procedure Send(bufPtr: array of Byte; len: DWORD; timeout: DWORD);
//返回接收的字节数
function Receive(out bufPtr: array of Byte; len: DWORD; timeout: DWORD): Integer; overload;
//返回接收的字节数
function Receive(out bufPtr: array of Byte; len: DWORD; const startBytes, endBytes: array of Byte; timeout: DWORD): Integer; overload;
//返回接收的字节数
function ReceiveByte(out bufPtr: Byte; timeout: DWORD): Integer;

function PurgeInput: Integer;
function PurgeOutput: Integer;
function ClearInput: Integer;
function ClearOutput: Integer;
function AbortInput: Integer;
function AbortOutput: Integer;
function Drain: Integer;
function Flush: Integer;

function IsOpen: Boolean;
function IsOverlapped: Boolean;

function ConfigDialog: Integer;

function ClearLineErrors: Integer;
function ResetDevice: Integer;
function ClearBreak: Integer;
function SetBreak: Integer;
function ClearDTR: Integer;
function SetDTR: Integer;
function ClearRTS: Integer;
function SetRTS: Integer;
function SetXOn: Integer;
function SetXOff: Integer;

property Handle: THandle read FHandle;
property Port: Integer read FPort write SetPort;
property BaudRate: DWORD read FBaudRate write SetBaudRate;
property DataBits: Integer read FDataBits write SetDataBits;
property Parity: Integer read FParity write SetParity;
property StopBits: Integer read FStopBits write SetStopBits;
property FlowControl: Integer read FFlowControl write SetFlowControl;
  end;

  procedure EnumDevices(List: TStrings);
  procedure EnumComDevices(List: TStrings);
  procedure EnumComDevicesFromRegistry(List: TStrings);

implementation

procedure EnumDevices(List: TStrings);
var
  Count, Start, i: Integer;
  Buffer: array [0..$FFFE] of Char;
  DeviceName: string;
begin
  Count := QueryDosDevice(nil, Buffer, SizeOf(Buffer));

  Start := 0;
  for i := 0 to Count - 1 do
if Buffer[i] = #0 then
begin
   DeviceName := StrPas(PChar(@Buffer[Start]));
   if DeviceName <> '' then
      List.Add(DeviceName);
   Start := i + 1;
end;
end;

procedure EnumComDevices(List: TStrings);
var
  Count, Start, i: Integer;
  Buffer: array [0..$FFFE] of Char;
  DeviceName: String;
begin
  Count := QueryDosDevice(nil, Buffer, SizeOf(Buffer));

  Start := 0;
  for i := 0 to Count - 1 do
if Buffer[i] = #0 then
begin
   DeviceName := StrPas(PChar(@Buffer[Start]));
   if (Pos('COM', DeviceName) = 1) or (Pos('\\.\COM', DeviceName) = 1) then
      List.Add(DeviceName);
   Start := i + 1;
end;
end;

procedure EnumComDevicesFromRegistry(List: TStrings);
var
  Names: TStringList;
  i: Integer;
begin
  with TRegistry.Create do
  try
RootKey := HKEY_LOCAL_MACHINE;
   if OpenKeyReadOnly('\HARDWARE\DEVICEMAP\SERIALCOMM') then
   begin
      Names := TStringList.Create;
      try
      GetValueNames(Names);
      for i := 0 to Names.Count - 1 do
         if GetDataType(Names[i]) = rdString then
            List.Add(ReadString(Names[i]));
      finally
      Names.Free;
      end
   end;
  finally
Free;
  end;
end;

constructor TSerialPort.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FHandle := INVALID_HANDLE_VALUE;
  FPort := 1;
  FBaudRate := CBR_9600;
  FDataBits := SER_DATABITS_8;
  FParity := SER_PARITY_NONE;
  FStopBits := SER_STOPBITS_1;
  FFlowControl := SER_HANDSHAKE_NONE;

  FOverlapped := False;

  timeoutTimer := TSiTimer.Create;
end;

destructor TSerialPort.Destroy;
begin
  timeoutTimer.Free;
  Close;
  inherited Destroy;
end;

function TSerialPort.Open(port: Integer; overlapped: Boolean): Integer;
var
  flags: Cardinal;
begin
  if IsOpen then Close;

  FPort := port;
  FOverlapped := overlapped;
  flags := 0;
  if FOverlapped then flags := FILE_FLAG_OVERLAPPED;

  FHandle := CreateFile(PChar('\\.\COM' + IntToStr(FPort)),
                     GENERIC_READ or GENERIC_WRITE, 0, nil, OPEN_EXISTING, flags, 0);

  if (FHandle = INVALID_HANDLE_VALUE) then
  begin
case GetLastError of
   ERROR_FILE_NOT_FOUND:
   begin
      Result := (SER_PORT_NOT_FOUND);
      Exit;
   end;
   ERROR_ACCESS_DENIED:
   begin
      Result := (SER_ALREADY_OPEN);
      Exit;
   end;
else
   begin
      Result := (SER_API_ERROR);
      Exit;
   end;
end;
  end;

  // Save current device control block
  if (not GetCommState(FHandle, savedDevCtrlBlock)) then
  begin
Result := (SER_API_ERROR);
Exit;
  end;

  if (not GetCommtimeouts(FHandle, savedCommtimeoutBlock)) then
  begin
Result := (SER_API_ERROR);
Exit;
  end;

  if FOverlapped then
  begin
ZeroMemory(@commtimeoutBlock, SizeOf(commtimeoutBlock));
SetCommtimeouts(FHandle, commtimeoutBlock);

ZeroMemory(@ovInternal,SizeOf(ovInternal));
ovInternal.hEvent := CreateEvent(nil,True,False,nil);

//如果无法创建事件，转为同步通讯模式
if (ovInternal.hEvent=0) then
   FOverlapped := False;
  end;

  Flush();
  Result := (Config(FBaudRate, FDataBits, FStopBits, FParity, FFlowControl));
end;

procedure TSerialPort.Close;
begin
  Flush(); // Clear buffer in case OS won't do it for us
  // Restore saved device control block
  SetCommState(FHandle, savedDevCtrlBlock);
  SetCommtimeouts(FHandle, savedCommtimeoutBlock);

  if (FOverlapped and (ovInternal.hEvent<>0)) then
  begin
   CloseHandle(ovInternal.hEvent);
   ovInternal.hEvent := 0;
  end;

  CloseHandle(FHandle);
  FHandle := INVALID_HANDLE_VALUE;
end;

function TSerialPort.Config(baudRate: DWORD; dataBits: Integer; stopBits: Integer;
                        parity: Integer; flowControl: Integer): Integer;
const
  flagBinary             = $00000001;
  flagParity             = $00000002;
  flagOutxCtsFlow          = $00000004;
  flagOutxDsrFlow          = $00000008;
  flagDtrControlEnable    = $00000010;
  flagDtrControlHandshake = $00000020;
  flagDtrControl          = $00000030;
  flagDsrSensitivity       = $00000040;
  flagTXContinueOnXoff    = $00000080;
  flagOutX                = $00000100;
  flagInX                = $00000200;
  flagErrorChar          = $00000400;
  flagNull                = $00000800;
  flagRtsControlEnable    = $00001000;
  flagRtsControlHandshake = $00002000;
  flagRtsControlToggle    = $00003000;
  flagAbortOnError       = $00004000;
  flagDummy2             = $FFFF8000;

  //流控制
  flagProtocolCommon    = flagBinary or flagDtrControlEnable {or flagAbortOnError};
  flagProtocolNone    = flagProtocolCommon or flagRtsControlEnable;
  flagProtocolXOnXOff = flagProtocolCommon or flagOutX or flagInX or flagRtsControlEnable;
  flagProtocolHardware = flagProtocolCommon or flagOutxCtsFlow or flagRtsControlHandshake;
  flagProtocolRS485    = flagProtocolCommon or flagRtsControlToggle;
  flagProtocolClear    = not (flagProtocolHardware or flagProtocolXOnXOff or flagDummy2 or flagProtocolRS485);
var
  devCtrlBlock: DCB;
  flags: Longint;
begin
  Result := (SER_NOT_OPEN);
  if (IsOpen) then
  begin
// Retrieve current device control block
if (not GetCommState(FHandle, devCtrlBlock)) then
begin
   Result := (SER_API_ERROR);
   Exit;
end;

// Modify device control block
devCtrlBlock.BaudRate := baudRate;
case dataBits of
   SER_DATABITS_4:
      devCtrlBlock.ByteSize := 4;
   SER_DATABITS_5:
      devCtrlBlock.ByteSize := 5;
   SER_DATABITS_6:
      devCtrlBlock.ByteSize := 6;
   SER_DATABITS_7:
      devCtrlBlock.ByteSize := 7;
   SER_DATABITS_8:
      devCtrlBlock.ByteSize := 8;
else
   begin
      Result := (SER_INVALID_PARAMETER);
      Exit;
   end;
end;

case stopBits of
   SER_STOPBITS_1:
      devCtrlBlock.StopBits := ONESTOPBIT;
   SER_STOPBITS_15:
      devCtrlBlock.StopBits := ONE5STOPBITS;
   SER_STOPBITS_2:
      devCtrlBlock.StopBits := TWOSTOPBITS;
else
   begin
      Result := (SER_INVALID_PARAMETER);
      Exit;
   end;
end;

flags := devCtrlBlock.Flags;
case parity of
   SER_PARITY_NONE:
   begin
      flags := flags and (not flagParity);
      devCtrlBlock.Parity := NOPARITY;
   end;
   SER_PARITY_EVEN:
   begin
      flags := flags or flagParity;
      devCtrlBlock.Parity := EVENPARITY;
   end;
   SER_PARITY_ODD:
   begin
      flags := flags or flagParity;
      devCtrlBlock.Parity := ODDPARITY;
   end;
   SER_PARITY_MARK:
   begin
      flags := flags or flagParity;
      devCtrlBlock.Parity := MARKPARITY;
   end;
   SER_PARITY_SPACE:
   begin
      flags := flags or flagParity;
      devCtrlBlock.Parity := SPACEPARITY;
   end;
else
   begin
      Result := (SER_INVALID_PARAMETER);
      Exit;
   end;
end;

flags := flags and flagProtocolClear;
case flowControl of
   SER_HANDSHAKE_NONE:
   begin
      flags := flags or flagProtocolNone;
   end;
   SER_HANDSHAKE_XONXOFF:
   begin
      flags := flags or flagProtocolXOnXOff;
   end;
   SER_HANDSHAKE_HARDWARE:
   begin
      flags := flags or flagProtocolHardware;
   end;
else
   begin
      Result := (SER_INVALID_PARAMETER);
      Exit;
   end;
end;

flags := flags and (not (flagErrorChar or flagNull or flagAbortOnError));

devCtrlBlock.Flags := flags;

devCtrlBlock.XonLim := 80;
devCtrlBlock.XoffLim  := 200;
devCtrlBlock.XonChar  := #$11;
devCtrlBlock.XoffChar := #$13;

// Store device control block
Result := (SER_INVALID_PARAMETER);
if SetCommState(FHandle, devCtrlBlock) then
begin
   FBaudRate := baudRate;
   FDataBits := dataBits;
   FParity := parity;
   FStopBits := stopBits;
   FFlowControl := flowControl;
   Result := (SER_SUCCESS);
end;
  end;
end;

function TSerialPort.IsOpen: Boolean;
begin
Result := FHandle <> INVALID_HANDLE_VALUE;
end;

function TSerialPort.IsOverlapped:Boolean;
begin
Result := FOverlapped;
end;

function TSerialPort.SetBufferSizes(input: DWORD; output: DWORD): Integer;
begin
  Result := (SER_NOT_OPEN);
  if (IsOpen) then
  begin
Result := SER_INVALID_PARAMETER;
if SetupComm(FHandle, input, output) then
   Result := SER_SUCCESS;
  end;
end;

function TSerialPort.Flush: Integer;
begin
  Result := (SER_NOT_OPEN);
  if (IsOpen) then
  begin
Result := (SER_API_ERROR);
if PurgeComm(FHandle, PURGE_TXCLEAR or PURGE_RXCLEAR) then
   Result := (SER_SUCCESS);
  end;
end;

function TSerialPort.Drain: Integer;
begin
  Result := (SER_NOT_OPEN);
  if (IsOpen) then
  begin
if (flowControl <> SER_HANDSHAKE_NONE) then
begin
   Result := (SER_UNSUPPORTED_OPERATION);
   Exit;
end;

ZeroMemory(@commtimeoutBlock, SizeOf (commtimeoutBlock));
if (not SetCommtimeouts(FHandle, commtimeoutBlock)) then
begin
   Result := (SER_API_ERROR);
   Exit;
end;

Result := (SER_API_ERROR);
if FlushFileBuffers(FHandle) then
   Result := (SER_SUCCESS);
  end;
end;

function TSerialPort.PurgeInput: Integer;
begin
  Result := (SER_NOT_OPEN);
  if (IsOpen) then
  begin
Result := SER_API_ERROR;
if PurgeComm(FHandle, PURGE_RXABORT or PURGE_RXCLEAR) then
   Result := (SER_SUCCESS);
  end;

end;

function TSerialPort.PurgeOutput: Integer;
begin
  Result := (SER_NOT_OPEN);
  if (IsOpen) then
  begin
Result := SER_API_ERROR;
if PurgeComm(FHandle, PURGE_TXABORT or PURGE_TXCLEAR) then
   Result := (SER_SUCCESS);
  end;

end;

function TSerialPort.ClearInput: Integer;
begin
  Result := (SER_NOT_OPEN);
  if (IsOpen) then
  begin
Result := SER_API_ERROR;
if PurgeComm(FHandle, PURGE_RXCLEAR) then
   Result := (SER_SUCCESS);
  end;

end;

function TSerialPort.ClearOutput: Integer;
begin
  Result := (SER_NOT_OPEN);
  if (IsOpen) then
  begin
Result := SER_API_ERROR;
if PurgeComm(FHandle, PURGE_TXCLEAR) then
   Result := (SER_SUCCESS);
  end;
end;

function TSerialPort.AbortInput: Integer;
begin
  Result := (SER_NOT_OPEN);
  if (IsOpen) then
  begin
Result := SER_API_ERROR;
if PurgeComm(FHandle, PURGE_RXABORT) then
   Result := (SER_SUCCESS);
  end;
end;

function TSerialPort.AbortOutput: Integer;
begin
  Result := (SER_NOT_OPEN);
  if (IsOpen) then
  begin
Result := SER_API_ERROR;
if PurgeComm(FHandle, PURGE_TXABORT) then
   Result := (SER_SUCCESS);
  end;
end;

function TSerialPort.SetBreak: Integer;
begin
  Result := (SER_NOT_OPEN);
  if (IsOpen) then
  begin
Result := SER_API_ERROR;
if SetCommBreak(FHandle) then
   Result := (SER_SUCCESS);
  end;
end;

function TSerialPort.ClearBreak: Integer;
begin
  Result := (SER_NOT_OPEN);
  if (IsOpen) then
  begin
Result := SER_API_ERROR;
if ClearCommBreak(FHandle) then
   Result := (SER_SUCCESS);
  end;

end;

function TSerialPort.SetDTR: Integer;
begin
  Result := (SER_NOT_OPEN);
  if (IsOpen) then
  begin
Result := SER_API_ERROR;
if EscapeCommFunction(FHandle, Windows.SETDTR) then
   Result := (SER_SUCCESS);
  end;

end;

function TSerialPort.ClearDTR: Integer;
begin
  Result := (SER_NOT_OPEN);
  if (IsOpen) then
  begin
Result := SER_API_ERROR;
if EscapeCommFunction(FHandle, CLRDTR) then
   Result := (SER_SUCCESS);
  end;

end;

function TSerialPort.SetRTS: Integer;
begin
  Result := (SER_NOT_OPEN);
  if (IsOpen) then
  begin
if (flowControl <> SER_HANDSHAKE_NONE) then
begin
   Result := (SER_UNSUPPORTED_OPERATION);
   Exit;
end;

Result := SER_API_ERROR;
if EscapeCommFunction(FHandle, Windows.SETRTS) then
   Result := (SER_SUCCESS);
  end;
end;

function TSerialPort.ClearRTS: Integer;
begin
  Result := (SER_NOT_OPEN);
  if (IsOpen) then
  begin
if (flowControl <> SER_HANDSHAKE_NONE) then
begin
   Result := (SER_UNSUPPORTED_OPERATION);
   Exit;
end;

Result := SER_API_ERROR;
if EscapeCommFunction(FHandle, CLRRTS) then
   Result := (SER_SUCCESS);
  end;
end;

function TSerialPort.SetXOn: Integer;
begin
  Result := (SER_NOT_OPEN);
  if (IsOpen) then
  begin
Result := SER_API_ERROR;
if EscapeCommFunction(FHandle, Windows.SETXON) then
   Result := (SER_SUCCESS);
  end;

end;

function TSerialPort.SetXOff: Integer;
begin
  Result := (SER_NOT_OPEN);
  if (IsOpen) then
  begin
Result := SER_API_ERROR;
if EscapeCommFunction(FHandle, Windows.SETXOFF) then
   Result := (SER_SUCCESS);
  end;

end;

function TSerialPort.ResetDevice: Integer;
begin
  Result := (SER_NOT_OPEN);
  if (IsOpen) then
  begin
Result := SER_API_ERROR;
if EscapeCommFunction(FHandle, RESETDEV) then
   Result := (SER_SUCCESS);
  end;

end;

function TSerialPort.ClearLineErrors: Integer;
var
  dwError: DWORD;
begin
  Result := (SER_NOT_OPEN);
  if (IsOpen) then
  begin
Result := SER_API_ERROR;
if ClearCommError(FHandle, dwError, nil) then
   Result := (SER_SUCCESS);
  end;
end;

function TSerialPort.ConfigDialog: Integer;
var
  Device: string;
  CommConfig: TCommConfig;
  dwSize: DWord;
begin
  Device := 'COM' + IntToStr(FPort);
  dwSize := SizeOf(CommConfig);
  Result := SER_API_ERROR;
  if GetDefaultCommConfig(PChar(Device), CommConfig, dwSize) then
  begin
if CommConfigDialog(PChar(Device), 0, CommConfig) then
begin
   if SetDefaultCommConfig(PChar(Device), @CommConfig, dwSize) then
      Result := SER_SUCCESS;
end;
  end;
end;

procedure TSerialPort.SyncSend(bufPtr: array of Byte; len: DWORD; timeout: DWORD);
var
  bytesSent: DWORD;
begin
  if (IsOpen) then
  begin
ZeroMemory(@commtimeoutBlock, SizeOf(commtimeoutBlock));
commtimeoutBlock.WriteTotaltimeoutConstant := timeout;
commtimeoutBlock.WriteTotaltimeoutMultiplier := 0;
if SetCommtimeouts(FHandle, commtimeoutBlock) then
begin
   bytesSent := 0;
   WriteFile(FHandle, bufPtr, len, bytesSent, nil);
end;
  end;
end;

function TSerialPort.SyncReceive(out bufPtr: array of Byte; len: DWORD; timeout: DWORD): Integer;
var
  bytesRead: DWORD;
begin
  Result := 0;
  if (IsOpen) then
  begin
ZeroMemory(@commtimeoutBlock, SizeOf(commtimeoutBlock));
commtimeoutBlock.ReadTotaltimeoutConstant := timeout;
if SetCommtimeouts(FHandle, commtimeoutBlock) then
begin
   bytesRead := 0;
   if ReadFile(FHandle, bufPtr, len, bytesRead, nil) then
      Result := bytesRead;
end;
  end;
end;

function TSerialPort.SyncReceiveByte(out bufPtr: Byte; timeout: DWORD): Integer;
begin
  Result := SyncReceive(bufPtr, 1, timeout);
end;

procedure TSerialPort.AsyncSend(bufPtr: array of Byte; len: DWORD; timeout: DWORD);
var
  bytesSent: DWORD;
  Stat: TComStat;
  dwError: DWORD;
begin
  if (IsOpen) then
  begin
if (ClearCommError(FHandle, dwError, @Stat)) then
begin
   if (dwError > 0) then
   begin
      PurgeComm(FHandle, PURGE_TXABORT or PURGE_TXCLEAR);
   end
   else
   begin
      ovInternal.Internal := 0;
      ovInternal.InternalHigh := 0;
      ovInternal.Offset := 0;
      ovInternal.OffsetHigh := 0;

      bytesSent := 0;

      if (WriteFile(FHandle, bufPtr, len, bytesSent, @ovInternal)) then
      begin

      end
      else
      begin
      case GetLastError of
         ERROR_IO_PENDING:
            case (WaitForSingleObject(ovInternal.hEvent, timeout)) of
            WAIT_OBJECT_0:
            begin
               GetOverlappedResult(FHandle, ovInternal, bytesSent, False);
            end;
            else
            begin
               PurgeComm(FHandle, PURGE_TXABORT or PURGE_TXCLEAR);
            end;
            end;
         ERROR_ACCESS_DENIED:
            begin
            PurgeComm(FHandle, PURGE_TXABORT or PURGE_TXCLEAR);
            end;
      else
         begin
            PurgeComm(FHandle, PURGE_TXABORT or PURGE_TXCLEAR);
         end;
      end;
      end;
   end;
end;
  end;
end;

function TSerialPort.AsyncReceive(out bufPtr: array of Byte; len: DWORD; timeout: DWORD): Integer;
var
  bytesRead: DWORD;
  Stat: TComStat;
  dwError: DWORD;
begin
  Result := 0;
  if (IsOpen) then
  begin
if (ClearCommError(FHandle, dwError, @Stat)) then
begin
   if (dwError > 0) then
   begin
      PurgeComm(FHandle, PURGE_RXABORT or PURGE_RXCLEAR);
   end
   else
   begin
      ovInternal.Internal := 0;
      ovInternal.InternalHigh := 0;
      ovInternal.Offset := 0;
      ovInternal.OffsetHigh := 0;

      bytesRead := 0;

      if (ReadFile(FHandle, bufPtr, len, bytesRead, @ovInternal)) then
      begin
      Result := len;
      end
      else
      begin
      case GetLastError of
         ERROR_IO_PENDING:
            case (WaitForSingleObject(ovInternal.hEvent, timeout)) of
            WAIT_OBJECT_0:
            begin
               GetOverlappedResult(FHandle, ovInternal, bytesRead, False);
               Result := bytesRead;
            end;
            else
            begin
               PurgeComm(FHandle, PURGE_RXABORT or PURGE_RXCLEAR);
            end;
            end;
         ERROR_ACCESS_DENIED:
            begin
            PurgeComm(FHandle, PURGE_RXABORT or PURGE_RXCLEAR);
            end;
      else
         begin
            PurgeComm(FHandle, PURGE_RXABORT or PURGE_RXCLEAR);
         end;
      end;
      end;
   end;
end;
  end;
end;

function TSerialPort.AsyncReceiveByte(out bufPtr: Byte; timeout: DWORD): Integer;
begin
  Result := AsyncReceive(bufPtr, 1, timeout);
end;

procedure TSerialPort.Send(bufPtr: array of Byte; len: DWORD; timeout: DWORD);
begin
  if FOverlapped then
  begin
AsyncSend(bufPtr, len, timeout);
  end
  else
  begin
SyncSend(bufPtr, len, timeout);
Drain;
  end;
end;

function TSerialPort.Receive(out bufPtr: array of Byte; len: DWORD; timeout: DWORD): Integer;
begin
  if FOverlapped then
  begin
Result := AsyncReceive(bufPtr, len, timeout);
  end
  else
  begin
Result := SyncReceive(bufPtr, len, timeout);
  end;
end;

function TSerialPort.Receive(out bufPtr: array of Byte; len: DWORD; const startBytes, endBytes: array of Byte; timeout: DWORD): Integer;
var
  bytesRead, FOffset, FIndex: Integer;
  FFlagStart, FFlagEnd: Boolean;
begin
  Result := 0;

  bytesRead := 0;
  FOffset := 0;
  FIndex := 0;
  FFlagStart := (High(startBytes) = -1);
  FFlagEnd := (High(endBytes) = -1);
  if (FFlagStart and FFlagEnd) then Exit;

  timeoutTimer.startMillis(timeout);
  while True do
  begin
if (timeoutTimer.isExpired()) then  Break;

if ((FOffset + 1) <= len) then
begin
   bytesRead := ReceiveByte(bufPtr[FOffset], timeout);
end
else
begin
   Break;
end;
Inc(FOffset, bytesRead);

if (not FFlagStart) then
begin
   if (bufPtr[FIndex] = startBytes[FIndex]) then
   begin
      Inc(FIndex);
   end
   else
   begin
      FOffset := 0;
      FIndex := 0;
   end;

   if (FIndex = Length(startBytes)) then
   begin
      FFlagStart := True;
      FIndex := 0;
   end;
end;

if ((not FFlagEnd) and FFlagStart) then
begin
   if (bufPtr[FOffset - 1] = endBytes[FIndex]) then
   begin
      Inc(FIndex);
   end
   else
   begin
      FIndex := 0;
   end;

   if (FIndex = Length(endBytes)) then
   begin
      FFlagEnd := True;
      FIndex := 0;
   end;
end;

if (FFlagStart and FFlagEnd) then
begin
   Result := FOffset;
   Break;
end;
  end;
end;

function TSerialPort.ReceiveByte(out bufPtr: Byte; timeout: DWORD): Integer;
begin
  if FOverlapped then
  begin
Result := AsyncReceiveByte(bufPtr, timeout);
  end
  else
  begin
Result := SyncReceiveByte(bufPtr, timeout);
  end;
end;

procedure TSerialPort.SetPort(Value: Integer);
begin
  if not IsOpen then FPort := Value;
end;

procedure TSerialPort.SetBaudRate(Value: DWORD);
begin
  if not IsOpen then FBaudRate := Value;
end;

procedure TSerialPort.SetDataBits(Value: Integer);
begin
  if not IsOpen then FDataBits := Value;
end;

procedure TSerialPort.SetParity(Value: Integer);
begin
  if not IsOpen then FParity := Value;
end;

procedure TSerialPort.SetStopBits(Value: Integer);
begin
  if not IsOpen then FStopBits := Value;
end;

procedure TSerialPort.SetFlowControl(Value: Integer);
begin
  if not IsOpen then FFlowControl := Value;
end;

end.

yqlomg · 发表于 2016-8-29 22:09:07

不明觉厉

霸气侧漏 · 发表于 2016-8-29 22:33:38

不明觉厉...不如直接上传个工程

coleyao · 发表于 2016-8-30 07:52:48

没有注释，有问题连啥地方有问题都搞不清楚！

cs128815 · 发表于 2016-8-30 08:25:24

楼主应该上传一个demo

WindDragon · 发表于 2016-8-30 10:15:10

CNPACK上有很好用的控件.

norman33 · 发表于 2016-8-30 10:17:31

Delphi3开始的老人握个爪现在delphi国内几乎绝迹了好怀念以前的大富翁

rube · 发表于 2016-8-30 11:25:21

comport3很好用

ysoni · 发表于 2016-8-30 14:04:38

cs128815 发表于 2016-8-30 08:25
楼主应该上传一个demo

串口操作是很普通的应用。TSerialPort已经是独立的类了。
成员函数命名也都可以从名称上直接理解。

提供的目的是帮助需要的人更好地理解编程，而不是拿来主义。　虽然代码是可以直接用的。

SkyGz · 发表于 2016-8-30 14:08:53

居然一个事件都没有........

一个Delphi下的串口类

阿莫论坛20周年了！感谢大家的支持与爱护！！