unicommx.pas

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

          FCurrentProtocolExecutor := nil;
        end
        else
          SafePostMessage(OwnerHwnd, WMT_CommCompleted, 0, Integer(FCommDevice.isInitiative));
        // 处理完毕后，通信状态转变为等待初始化
        FCommState := csInit;
      end;
  else
    begin
      // 其他状态，交由协议处理者自行处理
      if FCurrentTransferMode = tmCommander then
      begin
        FLastSendResult := SendCmd;
        try
           // cheer 2001.8.29
          if FCurrentProtocolExecutor <> nil then
            FHostCmd := FCurrentProtocolExecutor.ProcessProtocol(FCommState, FLastSendResult, FPacket, FParameters)
          else
            FCommState := csHalt;
        except
          FCommState := csHalt;
        end;
      end
      else
      begin
        if WaitFor_Any_Events([FCommDevice.Event_ConnectState], 0) = WAIT_OBJECT_0 then
        begin
          FCommState := csHalt;
          Exit;
        end;
        try
          try
            RespondeData := FCurrentProtocolExecutor.RespondCommand(FCommState, FCommDevice.GetDataAndClearBuf, FParameters, LastCmdComment, dwSleep);
          except
          end;
          // 如果没有检测到任何命令，则等待有字符传送过来。
          if RespondeData = '' then
            if WaitFor_Any_Events([FCommDevice.Event_DataArrive, Event_Terminate, FCommDevice.Event_ConnectState], Max_Idle_Time) <> WAIT_OBJECT_0 then
            begin
              FCommState := csHalt;
              Exit;
            end;
          if dwSleep <> 0 then
            if WaitFor_Any_Events([Event_Terminate], dwSleep) = WAIT_OBJECT_0 then Exit;
          if RespondeData <> '' then
            FCommDevice.SendData(RespondeData);
          if LastCmdComment <> '' then
            Debug(FCommDevice.DeviceName, '^^^^^^^^^^' + LastCmdComment + '^^^^^^^^^^');
        except
          FCommState := csHalt;
        end;
      end;
      SafePostMessage(OwnerHwnd, WMT_Progress, 0, GetProcessRatio);
    end;
  end;
end;

{
// 要求挂机

procedure TCommThread.NotifyHangup;
begin
  if (FCurrentTransferMode = tmCommander) then
    if (FCommState <> csInit) and (FCommState <> csWaitForInit) then
      FCommState := csNotifyHangup;
end;
}

function TCommThread.GetDataCount: Integer;
begin
  Result := FProtocolExecutorList.Count;
end;

function TCommThread.GetData(Index: Integer): string;
begin
  if Index < FProtocolExecutorList.Count then
    Result := TCustomProtocolExecutor(FProtocolExecutorList[Index]).Datas.Text;
end;

procedure TCommThread.DiscardData(Index: Integer);
begin
  if Index < FProtocolExecutorList.Count then
  begin
    TCustomProtocolExecutor(FProtocolExecutorList[Index]).Free;
    FProtocolExecutorList.Delete(Index);
  end;
end;

function TCommThread.GetProcessRatio: Integer;
begin
  if not Assigned(FCurrentProtocolExecutor) then
    Result := 0
  else
    Result := FCurrentProtocolExecutor.ProcessRatio;
end;

{---------------------- TUniComm ----------------------------}

{--------------------------------------------------------------------------
constructor TUniComm.Create;
功能： TUniComPort建构式
输入： 无
输出： 无
---------------------------------------------------------------------------}

constructor TUniComm.Create(AOwner: TComponent);
begin
  inherited;
  // 生成消息处理句柄
{$IFDEF VER140}
  FHWnd := Classes.AllocateHWnd(CommWndProc);
{$ELSE}
  FHWnd := AllocateHWnd(CommWndProc);
{$ENDIF}
  FParameters := TStringList.Create;
  FParameters.OnChange := OnParametersChange;
  FDatas := TList.Create;
  FBaudRate := br57600;
  FOptimize := omMinCPUUtilize;
  FCommThread := nil;
  FCommDevice := nil;
end;

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

destructor TUniComm.Destroy;
var
  i: Integer;
begin
  FParameters.Free;
  KillCommThread;
  KillCommDevice;
  for i := FDatas.Count - 1 downto 0 do
    TStrings(FDatas[i]).Free;
  FDatas.Free;
{$IFDEF VER140}
  Classes.DeallocateHWnd(FHwnd);
{$ELSE}
  DeallocateHWnd(FHwnd);
{$ENDIF}
  inherited;
end;

{--------------------------------------------------------------------------}

function TUniComm.GetCurrentData: string;
begin
  if Assigned(FCommThread) then
    Result := FCommThread.CurrentData
  else
    Result := '';
end;

{--------------------------------------------------------------------------
function TUniComm.GetDataCount: Integer;
功能： 取得数据的个数。此个数为通信完成的个数。每次通信完成，此个数会加一
输入： 无
输出： Integer  数据个数
---------------------------------------------------------------------------}

function TUniComm.GetDataCount: Integer;
begin
  Result := FDatas.Count;
end;

{--------------------------------------------------------------------------
function TUniComm.GetData
功能： 取得数据。
输入： Index 数据索引
输出： string 数据。实际格式为TStringList.Text
---------------------------------------------------------------------------}

function TUniComm.GetData(index: Integer): string;
begin
  if Index < FDatas.Count then
    Result := TStrings(FDatas[Index]).Text;
end;

{--------------------------------------------------------------------------
procedure TUniComm.DiscardData;
功能： 删除数据。
输入： Index 数据索引
输出： 无
---------------------------------------------------------------------------}

procedure TUniComm.DiscardData(Index: Integer);
begin
  if Index < FDatas.Count then
  begin
    TStrings(FDatas[Index]).Free;
    FDatas.Delete(Index);
  end;
end;

{--------------------------------------------------------------------------
procedure TUniComm.SetParameters;
功能： 设定协议参数
输入： value: TStrings 参数
输出： 无
---------------------------------------------------------------------------}

procedure TUniComm.SetParameters(value: TStringList);
begin
  FParameters.Assign(value);
  if Assigned(FCommThread) then
    FcommThread.Parameters.Assign(FParameters);
end;

procedure TUniComm.OnParametersChange(Sender: TObject);
begin
  if Assigned(FCommThread) then
    FcommThread.Parameters.Assign(FParameters);
end;

{  消息处理程序。根据不同的通信消息作不同处理 }
procedure TUniComm.CommWndProc(var msg: TMessage);
var
  InBuf: Pointer;
  InBuffSize: Integer;
  DisableOutBuffer: Boolean;
begin
  try
    case msg.msg of
      WMT_InitCompleted:
        begin
          if Assigned(FInitCompletedEvent) then
            FInitCompletedEvent(self, msg.LParam = 1);
        end;
      WMT_ConnectState:
        begin
          if Assigned(FConnectStateEvent) then
            FConnectStateEvent(self, msg.WParam = 1, msg.LParam = 1);
        end;
      WMT_Progress:
        begin
          if Assigned(FProgressEvent) then
            FProgressEvent(self, msg.LParam);
        end;
      WMT_DealData:
        begin
          if Assigned(FCommThread) and Assigned(FCommThread.CurrentProtocolExecutor) then
          begin
            InBuf := FCommThread.CurrentProtocolExecutor.inBuff;
            InBuffSize := FCommThread.CurrentProtocolExecutor.inBuffSize;
            try
              DisableOutBuffer := True;
              if Assigned(FDealDataEvent) then
                FDealDataEvent(Self, InBuf, InBuffSize, DisableOutBuffer);
            finally
              FCommThread.CurrentProtocolExecutor.OutBuffEnabled := not DisableOutBuffer;
              FCommThread.CurrentProtocolExecutor.Waiting := False;
            end;
          end;
        end;
      WMT_CommCompleted:
        begin
          SaveCommDatas;
          if Assigned(FCommCompletedEvent) then
            FCommCompletedEvent(self, msg.WParam = 1, msg.LParam = 1);
        end;
    end;
  except
  end;
end;

function TUniComm.GetDeviceType: TUniDeviceType;
begin
  Result := dtUnknown;
  if Assigned(FCommDevice) then
    Result := FCommDevice.DeviceType;
end;

{  初始化通信设备，并生成通信线程  }
procedure TUniComm.ResetComPort(DeviceType: TUniDeviceType = dtUnknown);
var
  DeviceClass: TCustomDeviceClass;
begin
  if DeviceType = dtUnknown then
  begin
    if not Assigned(FCommDevice) then
      raise Exception.Create('设备类型尚不支持');
    DeviceType := FCommDevice.DeviceType;
  end;
  DeviceClass := GetDevi