tscomm.pas

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

end;

constructor TTSComm.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
////////////////////////////////////////////////////////////////////////////////
  FErrorOptions := TErrorOptions.Create(self);
  FGeneralOption := TGeneralOption.Create(self);

  FSendList := TRecordList.Create;
  FReceiveList := TRecordList.Create;
  FSendRecord := nil;

  FHasSend := False;
  FHasReceive := False;

  TSComm1 := self;
    {启动多媒体定时器}
  FTimeID := timeSetEvent(1, 0, @TimeProc, 0, TIME_PERIODIC);
end;

destructor TTSComm.Destroy;
begin
    {关闭多谋体定时器}
  timeKillEvent(FTimeID);

  FReceiveList.Free;
  FSendList.Free;
  FErrorOptions.Free;
  FGeneralOption.Free;
  inherited Destroy;
end;

function TTSComm.SendAgain: boolean;
begin
  Result := False;
  if FSendList.Count > 0 then
  begin
    FSendRecord := FSendList.Items[0];
    if Assigned(FOnTSSendData) then
    begin
      FOnTSSendData(self, FSendList.Items[0]);
      Result := True;
    end;
  end;
end;

function TTSComm.SendNext: boolean;
begin
  Result := False;
  if not FGeneralOption.IsCumulateError then
    ClearErrorOptionIndex;
  if FSendList.Count > 0 then
  begin
    FSendList.Delete(0);
    Result := SendAgain;
  end;
end;

procedure TTSComm.SetDataBuffer(Value: string);
begin
  FDataBuffer := Value;
end;

function TTSComm.AddToSendList(AItem: Pointer): Integer;
begin
  Result := FSendList.Add(AItem);
  if FSendList.Count = 1 then
  begin
    if FErrorOptions.OverTimeErrorOption <> nil then
      FErrorOptions.OverTimeErrorOption.TimeIndex := 0;
    FHasSend := SendAgain;
  end;
end;

function TTSComm.AddToReceiveList(AItem: Pointer): Integer;
begin
  Result := FReceiveList.Add(AItem);
end;

procedure TTSComm.DeleteReceiveList(Index: Integer);
begin
  FReceiveList.Delete(Index);
end;

procedure TTSComm.SetErrorOptions(Value: TErrorOptions);
begin
  FErrorOptions.Assign(Value);
end;

procedure TTSComm.ClearErrorOptionIndex;
var i: Integer;
begin
  for i := 0 to ErrorOptions.Count - 1 do
  begin
    ErrorOptions[i].Index := 0;
  end;
end;

procedure TTSComm.SetGeneralOption(const Value: TGeneralOption);
begin
  FGeneralOption := Value;
end;

procedure TTSComm.ClearErrorOptionTimeIndex;
var i: Integer;
begin
  for i := 0 to ErrorOptions.Count - 1 do
  begin
    ErrorOptions[i].TimeIndex := 0;
  end;
end;

{ TCustomErrorOption }

function TCustomErrorOption.AddSendInfoValue(Value: Pointer): Integer;
begin
  Result := FSendInfoList.Add(Value);
end;

procedure TCustomErrorOption.Assign(Source: TPersistent);
begin
  if Source is TCustomErrorOption then
  begin
    self.FCount := TCustomErrorOption(Source).Count;
    self.FDelay := TCustomErrorOption(Source).Delay;
  end;
  inherited Assign(Source);
end;

constructor TCustomErrorOption.Create(Collection: TCollection);
begin
  inherited Create(Collection);
  FErrorStyle := esOther;
  FCount := 2;
  FDelay := 2000;
  FIndex := 0;
  FSendinfoList := TRecordList.Create;
  FDateTime := 0;
  FText := '';
  FEnabled := True;
end;

destructor TCustomErrorOption.Destroy;
begin
  FSendinfoList.Free;
  inherited Destroy;
end;

function TCustomErrorOption.GetDisplayName: string;
begin
  Result := Text;
  if Result = '' then Result := inherited GetDisplayName;
end;

procedure TCustomErrorOption.SetCount(const ACount: Word);
begin
  if FCount <> ACount then
    FCount := ACount;
end;

procedure TCustomErrorOption.SetDateTime(const ADateTime: TDateTime);
begin
  if FDateTime <> ADateTime then
    FDateTime := ADateTime;
end;

procedure TCustomErrorOption.SetDelay(const ADelay: Longword);
begin
  if FDelay <> ADelay then
    FDelay := ADelay;
end;

procedure TCustomErrorOption.SetEnabled(const AEnabled: Boolean);
begin
  if FEnabled <> AEnabled then
    FEnabled := AEnabled;
end;

procedure TCustomErrorOption.SetErrorStyle(
  const AErrorStyle: TErrorStyle);
var i: Integer;
begin
  if AErrorStyle = esOverTime then
  begin
    for i := 0 to Collection.Count - 1 do
      if TCustomErrorOption(Collection.Items[i]).FErrorStyle = esOverTime then Exit;
    if AErrorStyle = esOverTime then
    begin
      TErrorOptions(Collection).OverTimeErrorOption := Self;
      if TErrorOptions(Collection).CurrentErrorOption = nil then
        TErrorOptions(Collection).CurrentErrorOption := TErrorOptions(Collection).OverTimeErrorOption;
    end;
  end;
  if FErrorStyle <> AErrorStyle then
  begin
    FErrorStyle := AErrorStyle;
  end;
end;

procedure TCustomErrorOption.SetErrorIndex(const AIndex: Word);
begin
  if FIndex <> AIndex then
    FIndex := AIndex;
end;

procedure TCustomErrorOption.SetText(const AText: string);
begin
  if FText <> AText then
    FText := AText;
end;

procedure TCustomErrorOption.SetTimeIndex(const Value: Integer);
begin
  if FTimeIndex <> Value then
    FTimeIndex := Value;
end;

{ TRecordList }

procedure TRecordList.Notify(Ptr: Pointer; Action: TListNotification);
begin
  if Action = lnDeleted then
    Dispose(Ptr);
  inherited;
end;

{ TErrorOptions }

function TErrorOptions.Add: TCustomErrorOption;
begin
  Result := TCustomErrorOption(inherited Add);
end;

constructor TErrorOptions.Create(TSComm: TTSComm);
begin
  inherited Create(TCustomErrorOption);
  FTSComm := TSComm;
end;

function TErrorOptions.GetItem(Index: Integer): TCustomErrorOption;
begin
  Result := TCustomErrorOption(inherited GetItem(Index));
end;

function TErrorOptions.GetOwner: TPersistent;
begin
  Result := FTSComm;
end;

procedure TErrorOptions.SetCurrentErrorOption(
  const Value: TCustomErrorOption);
begin
  FCurrentErrorOption := Value;
end;

procedure TErrorOptions.SetItem(Index: Integer; Value: TCustomErrorOption);
begin
  inherited SetItem(Index, Value);
end;

procedure TErrorOptions.SetOverTimeErrorOption(
  const Value: TCustomErrorOption);
begin
  FOverTimeErrorOption := Value;
end;

procedure TErrorOptions.Update(Item: TCollectionItem);
begin
  inherited;
end;


{ TGeneralOption }

procedure TGeneralOption.AssignTo(Dest: TPersistent);
begin
  if Dest is TGeneralOption then
  begin
    FIsSingleCountError := TGeneralOption(Dest).IsSingleCountError;  //错误次数是否独立
    FIsSingleIndexError := TGeneralOption(Dest).IsSingleIndexError;  //错误当前次数是否独立
    FIsSingleDelayError := TGeneralOption(Dest).IsSingleDelayError;  //错误延迟时间是否独立
    FIsCumulateError := TGeneralOption(Dest).IsCumulateError;        //错误是否累积
    FErrorCount := TGeneralOption(Dest).ErrorCount;                  //错误总次数
    FErrorDelay := TGeneralOption(Dest).ErrorDelay;                  //错误延迟时间
    FSucceedDelay := TGeneralOption(Dest).SucceedDelay;              //接收数据成功后延迟
    FSucceedCount := TGeneralOption(Dest).SucceedCount;              //成功次数
  end;
  inherited AssignTo(Dest);
end;

constructor TGeneralOption.Create(TSComm: TTSComm);
begin
  inherited Create;
  FTSComm := TSComm;
  FIsSingleCountError := True;   //错误次数是否独立
  FIsSingleIndexError := False;  //错误当前次数是否独立
  FIsSingleDelayError := False;  //错误延迟时间是否独立
  FIsCumulateError := False;     //错误是否累积
  FErrorCount := 2;              //错误总次数
  FErrorDelay := 2000;           //错误延迟时间
  FErrorIndex := 0;              //错误次数
  FSucceedDelay := 1000;         //接收数据成功后延迟
  FSucceedDelayIndex := 0;       //接收数据成功后当前延迟
  FSucceedCount := 0;            //成功次数
  FSucceedCountIndex := 0;       //成功当前次数
end;

procedure TGeneralOption.SetErrorCount(const Value: Word);
begin
  FErrorCount := Value;
end;

procedure TGeneralOption.SetErrorDelay(const Value: Cardinal);
begin
  FErrorDelay := Value;
end;

procedure TGeneralOption.SetIsCumulateError(const Value: Boolean);
begin
  FIsCumulateError := Value;
end;

procedure TGeneralOption.SetIsSingleCountError(const Value: Boolean);
begin
  FIsSingleCountError := Value;
end;

procedure TGeneralOption.SetIsSingleDelayError(const Value: Boolean);
begin
  FIsSingleDelayError := Value;
end;

procedure TGeneralOption.SetIsSingleIndexError(const Value: Boolean);
begin
  FIsSingleIndexError := Value;
end;

procedure TGeneralOption.SetSucceedCount(const Value: Word);
begin
  FSucceedCount := Value;
end;

procedure TGeneralOption.SetSucceedDelay(const Value: Cardinal);
begin
  FSucceedDelay := Value;
end;

end.