userialcomm.pas

短信接收器程序可实现收短信、解析短信、删除短信、发送短信。

unit USerialComm;

interface

uses
  SysUtils, windows, Variants;

type
  TByteDynamicArray = array of byte;
  PByteDynamicArray = ^TByteDynamicArray;

  TReadBuffer = array[0..1024] of byte;
  PReadBuffer = ^TReadBuffer;

type
  TSerialComm = class(TObject)
  private
    { Private declarations }
    FPort: PChar;
    FDCB: DCB;
    FHANDLE: THandle;
    FTimeout: COMMTIMEOUTS;
    FBaudRate: DWord;
    FByteSize: DWord;
    FStopBit: DWord;
    FReadState: ComStat;
    FWriteBufferSize: DWord;
    FReadBufferSize: DWord;
    FError: byte;
    FOverlappedRead: TOverlapped;
  protected
    { protected declarations }
    function getIsOpened: boolean;
    procedure setBaudRate(const value: DWord);
    procedure setByteSize(const value: DWord);
    procedure setReadBufferSize(const value: DWord);
    procedure setWriteBufferSize(const value: DWord);
    procedure setStopBit(const value: DWord);
  published
    { published declarations }
    property IsOpened: boolean read getIsOpened;
    property DCBBaudRate: DWord read FBaudRate write setBaudRate;
    property DCBByteSize: DWord read FByteSize write setByteSize;
    property DCBStopBit: DWord read FStopBit write setStopBit;
    property ReadBufferSize: DWord read FReadBufferSize write setReadBufferSize;
    property WriteBufferSize: DWord read FWriteBufferSize write setWriteBufferSize;
  public
    { Public declarations }
    constructor Create(const aPort: string);
    destructor Destroy;
    function SendData(const buffer: array of byte; const timeout: DWord = 500): DWord; overload;
    function SendData(const buffer: string; const timeout: DWord = 500): DWord; overload;
    function ReadData(var buffer: TByteDynamicArray; const timeout: DWord = 1000): DWord; overload;
    function ReadData(var buffer: string; const timeout: DWord = 1000): DWord; overload;
    function Open: DWord;
    procedure Close;
    procedure Free;
  end;

  {communal function}
function getBCC(const pSource: array of byte; const index: integer = 0; const right: integer = 0): DWord;
function getCRC16(const pSource: array of byte; const index: integer = 0; const right: integer = 0): DWord;
function Right(const X: array of byte; const chr: byte): integer;

const
  STATUS_CMD_SUCCEED = $00;
  STATUS_INIT_SUCCEED = $00;
  STATUS_INIT_FAIL = $01;
  STATUS_SEND_FAIL = $02;
  STATUS_RECEIVE_FAIL = $03;

implementation

{ communal function }

function Right(const X: array of byte; const chr: byte): integer;
var
  i: integer;
begin
  result := -1;
  i := high(x);
  while i >= low(x) do begin
    if (x[i] = chr) then begin
      result := i;
      break;
    end;
    dec(i);
  end;
end;

function getBCC(const pSource: array of byte; const index, right: integer): DWord;
var
  i: integer;
begin
  result := 0;
  for i := low(pSource) + index to high(pSource) - right do
    result := result xor pSource[i];
end;

function getCRC16(const pSource: array of byte; const index, right: integer): DWord;
var
  i, k: integer;
begin
  result := 0;
  for i := low(pSource) + index to high(pSource) - right do begin
    result := result xor pSource[i];
    for k := 0 to 7 do
      if (result and $0001) <> 0 then begin
        result := result shr 1;
        result := result xor $08408; //POLYNOMIAL=$08408
      end
      else begin
        result := result shr 1;
      end;
  end;
end;

{ TSerialComm }

procedure TSerialComm.Close;
begin
  if (FOverlappedRead.hEvent <> 0) then begin
    CloseHandle(FOverlappedRead.hEvent);
    FOverlappedRead.hEvent := 0;
  end;
  if (FHANDLE <> INVALID_HANDLE_VALUE) then begin
    CloseHandle(FHANDLE);
    FHANDLE := 0;
  end;
end;

function TSerialComm.Open: DWord;
begin
  result := STATUS_INIT_FAIL;
  if IsOpened then
    Close;
  FillChar(FOverlappedRead, SizeOf(FOverlappedRead), 0);
  FOverlappedRead.hEvent := CreateEvent(nil, True, False, nil);
  FHANDLE := CreateFile(FPort, GENERIC_READ or GENERIC_WRITE, 0, nil, OPEN_EXISTING,
    FILE_ATTRIBUTE_NORMAL or FILE_FLAG_OVERLAPPED, 0);
  if (FHANDLE = INVALID_HANDLE_VALUE) or (FOverlappedRead.hEvent = 0) then begin
    result := STATUS_INIT_FAIL;
    Close;
    FError := GetLastError;
  end
  else if SetupComm(FHANDLE, FWriteBufferSize, FReadBufferSize) then begin
    GetCommTimeouts(FHANDLE, FTimeout);
    FTimeout.ReadIntervalTimeout := MAXDWORD;
    SetCommTimeouts(FHANDLE, FTimeout);

    GetCommState(FHANDLE, FDCB);
    FDCB.BaudRate := FBaudRate;
    FDCB.ByteSize := FByteSize;
    FDCB.Parity := NOPARITY;
    FDCB.StopBits := FStopBit;

    if not SetCommState(FHANDLE, FDCB) then
    begin
      Close;
      FError := GetLastError;
      result := STATUS_INIT_FAIL;
    end
    else
      if SetCommMask(FHANDLE, EV_RXCHAR) then
        result := STATUS_INIT_SUCCEED
      else
      begin
        Close;
        FError := GetLastError;
        result := STATUS_INIT_FAIL;
      end;

  end;
end;

constructor TSerialComm.Create(const aPort: string);
begin
  FPort := PChar(aPort);
  FBaudRate := 9600;
  FByteSize := 8;
  FillChar(FDCB, SizeOf(FDCB), 0);
  FStopBit := 0;
  FDCB.DCBlength := sizeof(FDCB);
  FillChar(FTimeout, SizeOf(FTimeout), 0);
  FTimeout.ReadIntervalTimeout := MAXDWORD;
  FTimeout.ReadTotalTimeoutMultiplier := 0;
  FTimeout.ReadTotalTimeoutConstant := 0;
  FWriteBufferSize := 4096;
  FReadBufferSize := 4096;
end;

procedure TSerialComm.Free;
begin
  if self <> nil then begin
    Close;
    Destroy;
  end;
end;

function TSerialComm.ReadData(var buffer: TByteDynamicArray;
  const timeout: DWord): DWord;
var
  i: integer;
  ErrorFlag, EventMask: DWord;
  OverlappedRead: TOverlapped;
  RealReadBufferSize: DWord;
  RealReadSize: DWord;
  RealBuffer: PReadBuffer;
  ReadBuffer: Pointer;
  SurplusSize: DWord;
  CurrTime: DWord;
begin
  result := STATUS_RECEIVE_FAIL;
  //if IsOpened and SetCommMask(FHANDLE, EV_RXCHAR) then begin
  if IsOpened then begin
    FOverlappedRead.Offset := 0;
    FOverlappedRead.OffsetHigh := 0;
    WaitForSingleObject(FHANDLE, timeout div 2);
    CurrTime := GetTickCount + timeout  ;
    EventMask := 0;
    FillChar(OverlappedRead, sizeof(OverlappedRead), 0);
    OverlappedRead.hEvent := CreateEvent(nil, True, False, nil);
    if OverlappedRead.hEvent <> 0 then
      if not WaitCommEvent(FHANDLE, EventMask, @OverlappedRead) then
        if (GetLastError = ERROR_IO_PENDING) then begin
          GetOverlappedResult(FHANDLE, OverlappedRead, RealReadSize, False);
        end;
    if ((EventMask and EV_RXCHAR) = EV_RXCHAR) then begin
      if not ClearCommError(FHANDLE, ErrorFlag, @FReadState) then begin
        PurgeComm(FHANDLE, PURGE_RXABORT or PURGE_RXCLEAR);
        result := STATUS_RECEIVE_FAIL;
      end
      else if FReadState.cbInQue > 0 then begin
        SurplusSize := FReadState.cbInQue;
        SetLength(buffer, SurplusSize);
        GetMem(ReadBuffer, SurplusSize + 1);
        RealReadBufferSize := 0;
        repeat
          if not ReadFile(FHANDLE, ReadBuffer^, SurplusSize,
            RealReadBufferSize, @FOverlappedRead) then begin
            ErrorFlag := GetLastError;
            if (ErrorFlag <> 0) and (ErrorFlag <> ERROR_IO_PENDING) then begin
              result := STATUS_RECEIVE_FAIL;
              break;
            end;
          end
          else begin
                  //WaitForSingleObject(FHANDLE,INFINITE);
            GetOverlappedResult(FHANDLE, FOverlappedRead, RealReadBufferSize, True);
          end;
          if RealReadBufferSize > 0 then begin
            FOverlappedRead.Offset := FOverlappedRead.Offset + RealReadBufferSize;
            RealBuffer := ReadBuffer;

            for i := 0 to RealReadBufferSize - 1 do
              buffer[i] := RealBuffer[i];
            result := STATUS_CMD_SUCCEED;
            break;
          end
          else begin
            result := STATUS_RECEIVE_FAIL;
            break;
          end;
        until CurrTime < GetTickCount;
        FreeMem(ReadBuffer);
      end;
    end;

    SetEvent(FOverlappedRead.hEvent);
    CloseHandle(OverlappedRead.hEvent);
  end;
end;

function TSerialComm.SendData(const buffer: array of byte; const timeout: DWord): DWord;
var
  ErrorFlag: DWord;
  i: integer;
  CurrPosition: DWord;
  RealWriteBufferSize: DWord;
  WriteBuffer: array of byte;
  WriteBufferSize: DWord;
  OverlappedWrite: TOverlapped;
begin
  result := STATUS_SEND_FAIL;
  if IsOpened then begin // and SetCommMask(FHANDLE, EV_RXCHAR)
    WriteBufferSize := sizeof(buffer);

    setlength(WriteBuffer, WriteBufferSize);
    for i := low(buffer) to high(buffer) do
      WriteBuffer[i] := buffer[i];
    CurrPosition := 0;

    FillChar(OverlappedWrite, SizeOf(OverlappedWrite), 0);
    OverlappedWrite.hEvent := CreateEvent(nil, True, False, nil);
    if OverlappedWrite.hEvent <> 0 then
      repeat
        if not WriteFile(FHANDLE, WriteBuffer[CurrPosition], WriteBufferSize,
          RealWriteBufferSize, @OverlappedWrite) then begin
          ErrorFlag := GetLastError;
          if (ErrorFlag <> 0) and (ErrorFlag = ERROR_IO_PENDING) then begin
            GetOverlappedResult(FHANDLE, OverlappedWrite, RealWriteBufferSize, True);
          end;
          if (RealWriteBufferSize > 0) then
            result := STATUS_CMD_SUCCEED
          else begin
            result := STATUS_SEND_FAIL;
            break;
          end;
        end;

        dec(WriteBufferSize, RealWriteBufferSize);
        inc(CurrPosition, RealWriteBufferSize);
      until (WriteBufferSize <= 0);
    WaitForSingleObject(FHANDLE, timeout);
    closeHandle(OverlappedWrite.hEvent);
    OverlappedWrite.hEvent := 0;
  end;
end;

function TSerialComm.getIsOpened: boolean;
begin
  if (FHANDLE <> INVALID_HANDLE_VALUE) and (FHANDLE <> 0) and (FError = 0)
    and (FOverlappedRead.hEvent <> 0) then
    result := TRUE
  else
    result := FALSE;
end;

procedure TSerialComm.setBaudRate(const value: DWord);
begin
  if not IsOpened then
    FBaudRate := value;
end;

procedure TSerialComm.setByteSize(const value: DWord);
begin
  if not IsOpened then
    FByteSize := value;
end;

procedure TSerialComm.setReadBufferSize(const value: DWord);
begin
  if not IsOpened then
    FReadBufferSize := value;
end;

procedure TSerialComm.setWriteBufferSize(const value: DWord);
begin
  if not IsOpened then
    FWriteBufferSize := value;
end;

destructor TSerialComm.Destroy;
begin
  inherited Destroy;
end;

procedure TSerialComm.setStopBit(const value: DWord);
begin
  if not IsOpened then
    FStopBit := value;
end;

function TSerialComm.ReadData(var buffer: string;
  const timeout: DWord): DWord;
var
  buf: TByteDynamicArray;
  i: integer;
begin
  result := ReadData(buf, timeout);
  for i := low(buf) to high(buf) do
    buffer := buffer + inttohex(buf[i], 2);
end;

function TSerialComm.SendData(const buffer: string;
  const timeout: DWord): DWord;
var
  buf: array of byte;
  i: integer;
begin
  for i := 1 to length(buffer) do begin
    setlength(buf, length(buf) + 1);
    buf[high(buf)] := ord(buffer[i]);
  end;
  result := SendData(buf, timeout);
end;

end.