tscomm.pas

一个比较好的串口控件(delphi 7.0)

//这是一个串行控件的加强版,它继承于SpCom.

// Author: 周益波 中国大陆
// Email:  [e-mail]
// StartDate: 2001/9/14

// version 1.00: 2001/9/19
//               - 用户收发数据更加方便,发送和接收数据都存在队列中,方便操作.
//               - 简化了对错误的处理过程,错误类型采用集中式管理.
//               - 自定义错误类型,可以是无限多个错误.
//               - 每个错误都有自己的重发次数和延迟时间.
//               - 错误次数可以是独立计数,也可以是混合计数.

unit TSComm;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  SPComm, extctrls, MMSystem;

    {以下为接收数据的检查结果消息}
{const TSCOM_USER                    = WM_USER + $100;       //用户自定义消息
      TSCOM_ALLRIGHT                = TSCOM_USER + $1;      //完全正确
      TSCOM_TOPOVERTIMEERROR        = TSCOM_USER + $2;      //上位机超时错误
      TSCOM_TOPFRAMEFORMATERROR     = TSCOM_USER + $3;      //上位机帧格式错误
      TSCOM_TOPCHECKSUMERROR        = TSCOM_USER + $4;      //上位机校验和错误
      TSCOM_BOTTOMOVERTIMEERROR     = TSCOM_USER + $5;      //下位机超时错误
      TSCOM_BOTTOMFRAMEFORMATERROR  = TSCOM_USER + $6;      //下位机帧格式错误
      TSCOM_BOTTOMCHECKSUMERROR     = TSCOM_USER + $7;      //下位机校验和错误
      TSCOM_OTHERERROR              = TSCOM_USER + $8;      //其他错误
}

const TSCOM_NULL = -2;              //没收到
      TSCOM_RIGHT = -1;             //收到错误

type
    {检查结果}
  TTSComm = class;

  TErrorStyle = (esOverTime, esOther);

    {存储结构的列表}
  TRecordList = class(TList)
  protected
    procedure Notify(Ptr: Pointer; Action: TListNotification); override;
  end;

    {接收数据事件}
  TTSReceiveDataEvent = procedure(Sender: TObject; Buffer: PChar; BufferLength: Word; HasSendData: Pointer;
                                  var ADataBuffer: string; var ErrorIndex: Integer) of object;

    {发送数据事件}
  TTSSendDataEvent = procedure(Sender: TObject; SendData: Pointer) of object;

    {接收数据错误事件}
  TTSReceiveErrorEvent = procedure(Sender: TObject; HasSendData: Pointer; ErrorIndex: Integer) of object;

    {分类错误事件}
  TTSSingleReceiveErrorEvent = procedure(Sender: TObject; HasSendData: Pointer; ErrorCount: Integer) of object;

    {错误设置类}
  TCustomErrorOption = class(TCollectionItem)
  private
    FErrorStyle: TErrorStyle;
    FCount: Word;
    FDelay: Longword;
    FTimeIndex: Integer;
    FIndex: Word;
    FSendInfoList: TRecordList;
    FDateTime: TDateTime;
    FText: string;
    FEnabled: Boolean;
    FOnTSSingleReceiveError: TTSSingleReceiveErrorEvent;
    procedure SetCount(const ACount: Word);
    procedure SetDelay(const ADelay: Longword);
    procedure SetErrorIndex(const AIndex: Word);
    procedure SetDateTime(const ADateTime: TDateTime);
    procedure SetText(const AText: string);
    procedure SetErrorStyle(const AErrorStyle: TErrorStyle);
    procedure SetEnabled(const AEnabled: Boolean);
    procedure SetTimeIndex(const Value: Integer);
  protected
    function GetDisplayName: string; override;
    property Index: Word read FIndex write SetErrorIndex;
    property DateTime: TDateTime read FDateTime write SetDateTime;
  public
    constructor Create(Collection: TCollection); override;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    function AddSendInfoValue(Value: Pointer): Integer;
    property TimeIndex: Integer read FTimeIndex Write SetTimeIndex;
    property SendInfoList: TRecordList read FSendInfoList;
  published
    property Count: Word read FCount write SetCount;
    property Delay: Longword read FDelay write SetDelay;
    property Text: string read FText write SetText;
    property Enabled: Boolean read FEnabled write SetEnabled;
    property ErrorStyle: TErrorStyle read FErrorStyle write SetErrorStyle;
    property OnTSSingleReceiveError: TTSSingleReceiveErrorEvent
      read FOnTSSingleReceiveError write FOnTSSingleReceiveError;
  end;

  TErrorOptions = class(TCollection)
  private
    FTSComm: TTSComm;
    FCurrentErrorOption: TCustomErrorOption; //当前错误
    FOverTimeErrorOption: TCustomErrorOption;//超时错误
    function GetItem(Index: Integer): TCustomErrorOption;
    procedure SetItem(Index: Integer; Value: TCustomErrorOption);
    procedure SetOverTimeErrorOption(const Value: TCustomErrorOption);
    procedure SetCurrentErrorOption(const Value: TCustomErrorOption);
  protected
    function GetOwner: TPersistent; override;
    procedure Update(Item: TCollectionItem); override;
  public
    constructor Create(TSComm: TTSComm);
    function Add: TCustomErrorOption;
    property Items[Index: Integer]: TCustomErrorOption read GetItem write SetItem; default;
    property CurrentErrorOption: TCustomErrorOption read FCurrentErrorOption write SetCurrentErrorOption;
    property OverTimeErrorOption: TCustomErrorOption read FOverTimeErrorOption write SetOverTimeErrorOption stored True;
  end;

  TGeneralOption = class(TPersistent)
  private
    FTSComm: TTSComm;
    FIsSingleCountError: Boolean;  //错误次数是否独立
    FIsSingleIndexError: Boolean;  //错误当前次数是否独立
    FIsSingleDelayError: Boolean;  //错误延迟时间是否独立
    FIsCumulateError: Boolean;     //错误是否累积
    FErrorCount: Word;             //错误总次数
    FErrorDelay: Cardinal;         //错误延迟时间
    FErrorIndex: Word;             //错误次数
    FSucceedDelay: Cardinal;       //接收数据成功后延迟
    FSucceedDelayIndex: Cardinal;  //接收数据成功后当前延迟
    FSucceedCount: Word;           //成功次数
    FSucceedCountIndex: Word;      //成功当前次数
    procedure SetErrorCount(const Value: Word);
    procedure SetErrorDelay(const Value: Cardinal);
    procedure SetIsCumulateError(const Value: Boolean);
    procedure SetIsSingleCountError(const Value: Boolean);
    procedure SetIsSingleDelayError(const Value: Boolean);
    procedure SetIsSingleIndexError(const Value: Boolean);
    procedure SetSucceedCount(const Value: Word);
    procedure SetSucceedDelay(const Value: Cardinal);
  protected
    procedure AssignTo(Dest: TPersistent); override;
  public
    constructor Create(TSComm: TTSComm); virtual;
  published
    property IsSingleCountError: Boolean read FIsSingleCountError write SetIsSingleCountError;
    property IsSingleDelayError: Boolean read FIsSingleDelayError write SetIsSingleDelayError;
    property IsSingleIndexError: Boolean read FIsSingleIndexError write SetIsSingleIndexError;
    property IsCumulateError: Boolean read FIsCumulateError write SetIsCumulateError;
    property ErrorCount: Word read FErrorCount write SetErrorCount;
    property ErrorDelay: Cardinal read FErrorDelay write SetErrorDelay;
    property SucceedDelay: Cardinal read FSucceedDelay write SetSucceedDelay;
    property SucceedCount: Word read FSucceedCount write SetSucceedCount;
  end;

    {串行通讯加强类}
  TTSComm = class(TComm)
  private
    FErrorOptions: TErrorOptions;
    FGeneralOption: TGeneralOption;
///////////////////////////////////////////////////////////////////////////////////////

    FSendList: TRecordList;           //发送数据列表
    FReceiveList: TRecordList;        //接收数据列表
    FSendRecord: Pointer;             //发送的数据

    FDataBuffer: string;              //经过自定义检查后的数据

    FTimeID: Longint;                 //多媒体定时器的返回值

    FHasSend: Boolean;                //数据是否已经发送
    FHasReceive: Boolean;             //数据是否已经接收

    {接受数据事件,在这里可以检测接收的数据的格式是否符合通讯协议}
    FOnTSReceiveData: TTSReceiveDataEvent;
    {发送数据事件,在这里可以编写怎样发送数据}
    FOnTSSendData: TTSSendDataEvent;
    {接收数据错误事件,在这里可以编写错误处理事件}
    FOnTSReceiveError: TTSReceiveErrorEvent;

    procedure SetDataBuffer(Value: string);
      {定时事件}
    procedure TimeProcedure;
    procedure SetErrorOption(ACustomErrorOption: TCustomErrorOption);
    procedure ClearErrorOptionIndex;
    procedure ClearErrorOptionTimeIndex;
    procedure SetGeneralOption(const Value: TGeneralOption);
  protected
    function Perform(Msg: Cardinal; WParam, LParam: Longint): Longint;
    procedure ReceiveData(Buffer: PChar; BufferLength: Word); override;
    procedure SetErrorOptions(Value: TErrorOptions);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
      {发送本列表头数据}
    function SendAgain: boolean;
      {发送下一项数据}
    function SendNext: boolean;
      {把发送数据添加进列表}
    function AddToSendList(AItem: Pointer): Integer;
      {把接收数据添加进列表}
    function AddToReceiveList(AItem: Pointer): Integer;
    procedure DeleteReceiveList(Index: Integer);

    property DataBuffer: string read FDataBuffer write SetDataBuffer;
    property SendList: TRecordList read FSendList write FSendList;
    property ReceiveList: TRecordList read FReceiveList write FReceiveList;
    property SendRecord: pointer read FSendRecord;

  published
    property ErrorOptions: TErrorOptions read FErrorOptions write SetErrorOptions;
    property GeneralOption: TGeneralOption read FGeneralOption write SetGeneralOption;

    property OnTSReceiveData: TTSReceiveDataEvent
      read FOnTSReceiveData write FOnTSReceiveData;
    property OnTSSendData: TTSSendDataEvent
      read FOnTSSendData write FOnTSSendData;
    property OnTSReceiveError: TTSReceiveErrorEvent
      read FOnTSReceiveError write FOnTSReceiveError;

  end;

  {回调函数,多谋体定时器}
procedure TimeProc(uID, uMsg, dwUser, dw1, dw2: Longint) stdcall;

var TSComm1: TTSComm;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Custom', [TTSComm]);
end;

{ TTSComm }

function TTSComm.Perform(Msg: Cardinal; WParam, LParam: Integer): Longint;
var
  Message: TMessage;
begin
  Message.Msg := Msg;
  Message.WParam := WParam;
  Message.LParam := LParam;
  Message.Result := 0;
  if Self <> nil then Dispatch(Message);
  Result := Message.Result;
end;

procedure TimeProc(uID, uMsg, dwUser, dw1, dw2: Longint) stdcall;
begin
  TSComm1.TimeProcedure;
end;

procedure TTSComm.TimeProcedure;
begin
  if FErrorOptions.CurrentErrorOption <> nil then
  begin
    FErrorOptions.CurrentErrorOption.TimeIndex := FErrorOptions.CurrentErrorOption.TimeIndex + 1;
    if FErrorOptions.CurrentErrorOption.TimeIndex > FErrorOptions.CurrentErrorOption.Delay then
    begin
      FErrorOptions.CurrentErrorOption.TimeIndex := 0;
      FErrorOptions.CurrentErrorOption := FErrorOptions.OverTimeErrorOption;
      SetErrorOption(FErrorOptions.CurrentErrorOption);
    end;
  end;
end;

procedure TTSComm.ReceiveData(Buffer: PChar; BufferLength: Word);
var ErrorIndex: Integer;
begin
  inherited ReceiveData(Buffer, BufferLength);
  if Assigned(FOnTSReceiveData) then
  begin
    ErrorIndex := TSCOM_NULL;
    FDataBuffer := '';
    FOnTSReceiveData(self, Buffer, BufferLength, FSendRecord, FDataBuffer, ErrorIndex);
    if (ErrorIndex >= 0) and (FErrorOptions[ErrorIndex].Enabled) then
    begin
      if FHasSend then
      begin
        FErrorOptions.CurrentErrorOption := FErrorOptions[ErrorIndex];
        SetErrorOption(FErrorOptions.CurrentErrorOption);
      end;
      FHasSend := False;
    end else if ErrorIndex = TSCOM_RIGHT then
    begin
      FErrorOptions.CurrentErrorOption.TimeIndex :=
        FErrorOptions.CurrentErrorOption.FDelay - FGeneralOption.FSucceedDelay;
      FHasReceive := True;
    end;
  end;
end;

procedure TTSComm.SetErrorOption(ACustomErrorOption: TCustomErrorOption);

  procedure SetErrorEvent(var AErrorIndex: Word; AErrorCount: Word);
  begin
    Inc(AErrorIndex);
    if Assigned(ACustomErrorOption.FOnTSSingleReceiveError) then
      ACustomErrorOption.FOnTSSingleReceiveError(ACustomErrorOption,
        FSendRecord, AErrorIndex);
    begin
      if AErrorIndex > AErrorCount then
      begin
        AErrorIndex := 0;
        if Assigned(FOnTSReceiveError) then
          FOnTSReceiveError(Self, FSendRecord, ACustomErrorOption.ID);
        if ACustomErrorOption.ErrorStyle = esOverTime then
          FHasSend := SendNext;
      end else
      begin
        if ACustomErrorOption.ErrorStyle = esOverTime then
          FHasSend := SendAgain;
      end;
    end;
  end;

  procedure SetSendData(var AErrorIndex: Word; AErrorCount: Word);
  begin
  end;

begin
  if not FHasReceive then     //如果没有收到
  begin
    if FHasSend then          //如果已经发送
    begin
      if FGeneralOption.IsSingleCountError then
      begin
        if FGeneralOption.IsSingleIndexError then
          SetErrorEvent(FGeneralOption.FErrorIndex, ACustomErrorOption.Count)
        else
          SetErrorEvent(ACustomErrorOption.FIndex, ACustomErrorOption.Count);
      end else
      begin
        SetErrorEvent(FGeneralOption.FErrorIndex, FGeneralOption.ErrorCount);
      end;
    end else                  //没有发送
    begin
      FHasSend := SendAgain;
    end;
  end else FHasSend := SendNext;
  FHasReceive := False;