unicommx.pas

很好用的串口通信工具软件。Comport目录下是用到的通信控件。

  FInBuffSize := 0;
  FOutBuff := nil;
  FOutBuffSize := 0;
  FOutBuffEnabled := True;
end;

{--------------------------------------------------------------------------
destructor TCustomProtocolExecutor.Destroy;
功能： TCustomProtocolExecutor 析构式
输入： 无
输出： 无
---------------------------------------------------------------------------}

destructor TCustomProtocolExecutor.Destroy;
begin
  FDatas.Free;
  if Assigned(FInBuff) then FreeMem(FInBuff); // 当输入缓冲区非空时，释放掉他
  FInBuffSize := 0;
  inherited;
end;

function TCustomProtocolExecutor.RespondCommand(var FCommState: Integer; Data: string; Parameters: TStrings; var LastCmdComment: string; var dwSleep: Cardinal): string;
begin
  Result := '';
  FDataBuff := FDataBuff + Data;        // 回应命令。这里只将数据存入缓冲区中，具体处理交由具体协议类实现
end;

{-------------------- TCommThread -------------------------}

constructor TCommThread.Create(OwnerHandle: THandle; CommDevice:
  TCustomCommDevice);
begin
  inherited Create(True);
  FActived := False;
  OwnerHwnd := OwnerHandle;
  FCommDevice := CommDevice;
  FParameters := TStringList.Create;
  FProtocolExecutorList := TList.Create; // 协议处理实例的缓冲区。每次通信完成后，当前的协议处理实例就会存放到从缓冲区中
  FCurrentProtocolExecutor := nil;
  Priority := tpHigher;                 // 通信线程的优先级应当比正常优先级高
  Event_Terminate := CreateEvent(nil, False, False, nil);
end;

{--------------------------------------------------------------------------
destructor TCommThread.Destroy;
功能：  TCommThread 析构式。
输入： 无
输出： 无
---------------------------------------------------------------------------}

destructor TCommThread.Destroy;
var
  I: Integer;
begin
  //安全退出
  SafeTerminate;
  // 关闭事件
  CloseHandle(Event_Terminate);
  FParameters.Free;
  // 释放协议处理实例的缓冲区
  for i := 0 to FProtocolExecutorList.Count - 1 do
    TCustomProtocolExecutor(FProtocolExecutorList[i]).Free;
  FProtocolExecutorList.Free;
  inherited;
end;

{--------------------------------------------------------------------------
procedure TCommThread.Execute;
功能：  线程的执行部分。命令发送完毕后，线程进入suspend状态
输入： 无
输出： 无
---------------------------------------------------------------------------}

procedure TCommThread.Execute;
begin
  repeat
    case FOptimize of
      omMinCPUUtilize:
        begin
          // 延时10ms，如果其间收到退出信号并且线程没有终止，则挂起线程；
          // 否则如果有数据等待发送，则发送数据，
          // 如果发送数据的结果为收到关闭信号，并且线程没有终止，则挂起线程。
          if WaitFor_Any_Events([Event_Terminate], 10) <> WAIT_OBJECT_0 then
            Process_Communication_Event;
        end;
      omMaxPerformance:
        begin
          // 不延时，直接处理通信中的消息
          Application.ProcessMessages;
          Process_Communication_Event;
        end;
    end;
  until Terminated;
end;

{--------------------------------------------------------------------------
procedure TCommThread.SafeTerminate;
功能：  安全快速终止线程
输入： 无
输出： 无
---------------------------------------------------------------------------}

procedure TCommThread.SafeTerminate;
begin
  // 设定线程 Terminated 标志为True
  Terminate;
  // 设定线程退出事件
  SetEvent(Event_Terminate);
  // 恢复线程运行
  while Suspended do
    Resume;
  // 等待线程终止
  if WaitFor_Any_Events([Handle], 5000) <> WAIT_OBJECT_0 then
  begin
    // 如果等待5秒钟线程还没有终止,则强制终止线程
    TerminateThread(Handle, 0);
  end;
end;

procedure TCommThread.SetTransferMode(value: TUniTransferMode);
begin
  if FDefaultTransferMode <> value then
  begin
    FDefaultTransferMode := value;

    //FCurrentTransferMode := value;
  end;
end;

{--------------------------------------------------------------------------
function TCommThread.SendCmd: Integer;
功能：  发送命令并得到发送结果。
输入： 无
输出： 发送结果
---------------------------------------------------------------------------}

function TCommThread.SendCmd: Integer;
var
  LResult: DWord;
  i, Send_Times, Echo_Pos: Integer;
  Time_Tag: DWord;
  DataBuff: string;
  bTimeOut, bLostCMD, bNAK: Boolean;
  sAside: string;
begin
  // 默认返回 NAK
  Result := srNAK;
  if FHostCmd.Command = '' then
  begin
    Debug(FCommDevice.DeviceName, '------' + FHostCmd.Comment +
      '(NULL COMMAND)');
    Result := srNullCommand;
    Exit;
  end;
  FPacket := '';
  DataBuff := '';
  Send_Times := 0;
  Debug(FCommDevice.DeviceName, '------' + FHostCmd.Comment + '------');
  FCommDevice.SendData(COMMAND_HEAD + FHostCmd.Command);
  // 如果要求回应为空，表明只要将此数据发送出去即可。
  if (Length(FHostCmd.Echos) = 0) and (FHostCmd.curACK = '') and (FHostCmd.curNAK = '') then
  begin
    if WaitFor_Any_Events([Event_Terminate, FCommDevice.Event_ConnectState], 100) <> Wait_TimeOut then
      Result := srTerminate
    else
      Result := srACK;
    Exit;
  end;
  inc(Send_Times);
  Time_Tag := GetTickCount;
  // 当发送次数小于最大发送次数且发送未成功时，一直发送并增加发送次数计数
  while (Send_Times < FHostCmd.Max_Send_Times) do
  begin
    // 等待事件：退出、或接收到数据、或超时
    LResult := WaitFor_Any_Events([Event_Terminate, FCommDevice.Event_ConnectState, FCommDevice.Event_DataArrive], FHostCmd.No_Response_Interval);
    if (LResult = Wait_Object_0) or (LResult = Wait_Object_0 + 1) then
    begin
      Result := srTerminate;
      Break;
    end;
    bLostCMD := LResult = Wait_TimeOut;
    // 确定数据头位置
    DataBuff := DataBuff + FCommDevice.GetDataAndClearBuf;
    bNAK := False;
    // 判断是否有回应数据
    for i := 0 to Length(FHostCmd.Echos) - 1 do
    begin
      Echo_Pos := Pos(FHostCmd.Echos[i].Echo_Head, DataBuff);
      if (Echo_Pos > 0) and (Length(DataBuff) >= Echo_Pos + FHostCmd.Echos[i].Echo_Size - 1) and
        ((not FHostCmd.Echos[i].Echo_HaveCRC) or (FHostCmd.Echos[i].Echo_HaveCRC and
        (GenerateCRC(DataBuff[Echo_Pos], FHostCmd.Echos[i].Echo_Size - 1) = Ord(DataBuff[Echo_Pos - 1 + FHostCmd.Echos[i].Echo_Size])))) then
      begin
        begin
          FPacket := Copy(DataBuff, Echo_Pos, FHostCmd.Echos[i].Echo_Size);
          Result := srGetData;
          Break;
        end;
      end;
    end;
    if Result = srGetData then Break;
    // 判断是否返回ACK
    if FHostCmd.curACK <> '' then
    begin
      Echo_Pos := Pos(FHostCmd.curACK, DataBuff);
      if Echo_Pos > 0 then
      begin
        FPacket := '';
        Result := srACK;
        Break;
      end;
    end;
    // 判断是否返回NAK
    if FHostCmd.curNAK <> '' then
    begin
      Echo_Pos := Pos(FHostCmd.curNAK, DataBuff);
      if Echo_Pos > 0 then
      begin
        FPacket := '';
        Result := srNAK;
        bNAK := True;
      end;
    end;
    // 如果超时或接收到NAK，则重新发送
    sAside := '';
    bTimeOut := Integer(GetTickCount - Time_Tag) >= FHostCmd.Send_Interval;
    if bTimeOut then
      sAside := sAside + '超时' + IntToStr(FHostCmd.Send_Interval) + 'ms';
    if bNAK then
      sAside := sAside + 'NAK';
    if bLostCMD then
      sAside := sAside + '无回应' + IntToStr(FHostCmd.No_Response_Interval) + 'ms';
    if bTimeOut or bNAK or bLostCMD then
    begin
      Time_Tag := GetTickCount;
      Debug(FCommDevice.DeviceName, '==========>' + FHostCmd.Comment + sAside);
      FPacket := '';
      DataBuff := '';
      FCommDevice.SendData(COMMAND_HEAD + FHostCmd.Command); // 重发
      Inc(Send_Times);
    end;
  end;
  FHostCmd.Command := '';
end;

{--------------------------------------------------------------------------
procedure TCommThread.SetActived
功能：  设定是否激活
输入： 无
输出： 发送结果
---------------------------------------------------------------------------}

procedure TCommThread.SetActived(value: boolean);
begin
  if FActived = value then
    Exit;
  FActived := value;
  // 当线程激活时，将通信状态改变为等待初始化，然后恢复线程运行
  if FActived then
  begin
    FCommState := csInit;
    while Suspended do
      Resume;
  end
end;

procedure TCommThread.SetParameters(value: TStrings);
begin
  FParameters.Assign(value);
end;

function TCommThread.GetBusy: Boolean;
begin
  Result := FCommState <> csWaitForConnect;
end;

{--------------------------------------------------------------------------
procedure TCommThread.SetOutBuff
功能：  设定待发缓冲区
输入： 无
输出： 发送结果
---------------------------------------------------------------------------}

procedure TCommThread.SetOutBuff(value: Pointer);
begin
  FOutBuff := value;
  // 当待发缓冲区改变时，生成新的通信标志，用以断点续传
  DataTag := UnicreateGUID;
  if Assigned(FCurrentProtocolExecutor) then
  begin
    FCurrentProtocolExecutor.OutBuff := value;
    FCurrentProtocolExecutor.DataTag := DataTag;
  end;
end;