unidevice_builtin.pas

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

procedure Register;

const
   // infinite wait
  WaitInfinite = Integer(INFINITE);

  // error codes
  CError_OpenFailed = 1;
  CError_WriteFailed = 2;
  CError_ReadFailed = 3;
  CError_InvalidAsync = 4;
  CError_PurgeFailed = 5;
  CError_AsyncCheck = 6;
  CError_SetStateFailed = 7;
  CError_TimeoutsFailed = 8;
  CError_SetupComFailed = 9;
  CError_ClearComFailed = 10;
  CError_ModemStatFailed = 11;
  CError_EscapeComFailed = 12;
  CError_TransmitFailed = 13;
  CError_SyncMeth = 14;
  CError_EnumPortsFailed = 15;
  CError_StoreFailed = 16;
  CError_LoadFailed = 17;
  CError_RegFailed = 18;
  CError_LedStateFailed = 19;
  CError_ThreadCreated = 20;
  CError_WaitFailed = 21;
  CError_HasLink = 22;

implementation

uses
  Controls, Forms, WinSpool;

const
  csCR = #$0D; // 回车
  csCRLF = #$0D#$0A; // 回车换行
  ComErrorMessages: array[1..22] of string =
  ('无法打开端口',
    'WriteFile function failed',
    'ReadFile function failed',
    'Invalid Async parameter',
    'PurgeComm function failed',
    'Unable to get async status',
    'SetCommState function failed',
    'SetCommTimeouts failed',
    'SetupComm function failed',
    'ClearCommError function failed',
    'GetCommModemStatus function failed',
    'EscapeCommFunction function failed',
    'TransmitCommChar function failed',
    'Cannot set SyncMethod while connected',
    'EnumPorts function failed',
    'Failed to store settings',
    'Failed to load settings',
    'Link (un)registration failed',
    'Cannot change led state if ComPort is selected',
    'Cannot wait for event if event thread is created',
    'WaitForEvent method failed',
    'A component is linked to OnRxBuf event');

  // auxilary constants used not defined in windows.pas
  dcb_Binary = $00000001;
  dcb_Parity = $00000002;
  dcb_OutxCTSFlow = $00000004;
  dcb_OutxDSRFlow = $00000008;
  dcb_DTRControl = $00000030;
  dcb_DSRSensivity = $00000040;
  dcb_TxContinueOnXoff = $00000080;
  dcb_OutX = $00000100;
  dcb_InX = $00000200;
  dcb_ErrorChar = $00000400;
  dcb_Null = $00000800;
  dcb_RTSControl = $00003000;
  dcb_AbortOnError = $00004000;

  // com port window message
  CM_COMPORT = WM_USER + 1;

(*****************************************
 * auxilary functions and procedures     *
 *****************************************)

// converts TComEvents type to Integer

procedure Register;
begin
  RegisterComponents('CPub', [TSerialPort]);
end;

function EventsToInt(const Events: TComEvents): Integer;
begin
  Result := 0;
  if evRxChar in Events then
    Result := Result or EV_RXCHAR;
  if evRxFlag in Events then
    Result := Result or EV_RXFLAG;
  if evTxEmpty in Events then
    Result := Result or EV_TXEMPTY;
  if evRing in Events then
    Result := Result or EV_RING;
  if evCTS in Events then
    Result := Result or EV_CTS;
  if evDSR in Events then
    Result := Result or EV_DSR;
  if evRLSD in Events then
    Result := Result or EV_RLSD;
  if evError in Events then
    Result := Result or EV_ERR;
  if evBreak in Events then
    Result := Result or EV_BREAK;
  if evRx80Full in Events then
    Result := Result or EV_RX80FULL;
end;

function IntToEvents(Mask: Integer): TComEvents;
begin
  Result := [];
  if (EV_RXCHAR and Mask) <> 0 then
    Result := Result + [evRxChar];
  if (EV_TXEMPTY and Mask) <> 0 then
    Result := Result + [evTxEmpty];
  if (EV_BREAK and Mask) <> 0 then
    Result := Result + [evBreak];
  if (EV_RING and Mask) <> 0 then
    Result := Result + [evRing];
  if (EV_CTS and Mask) <> 0 then
    Result := Result + [evCTS];
  if (EV_DSR and Mask) <> 0 then
    Result := Result + [evDSR];
  if (EV_RXFLAG and Mask) <> 0 then
    Result := Result + [evRxFlag];
  if (EV_RLSD and Mask) <> 0 then
    Result := Result + [evRLSD];
  if (EV_ERR and Mask) <> 0 then
    Result := Result + [evError];
  if (EV_RX80FULL and Mask) <> 0 then
    Result := Result + [evRx80Full];
end;

(*****************************************
 * TComThread class                      *
 *****************************************)

// create thread

constructor TComThread.Create(AComPort: TCustomSerialPort);
begin
  inherited Create(True);
  FStopEvent := CreateEvent(nil, True, False, nil);
  FComPort := AComPort;
  //Priority := tpTimeCritical;
  Priority := tpHighest;
  // select which events are monitored
  SetCommMask(FComPort.Handle, EventsToInt(FComPort.Events));
  // execute thread
  Resume;
end;

// destroy thread

destructor TComThread.Destroy;
begin
  Stop;
  inherited Destroy;
end;

// thread action

procedure TComThread.Execute;
var
  EventHandles: array[0..1] of THandle;
  Overlapped: TOverlapped;
  Signaled, BytesTrans, Mask: DWORD;
begin
  FillChar(Overlapped, SizeOf(Overlapped), 0);
  Overlapped.hEvent := CreateEvent(nil, True, True, nil);
  EventHandles[0] := FStopEvent;
  EventHandles[1] := Overlapped.hEvent;
  repeat
    // wait for event to occur on serial port
    WaitCommEvent(FComPort.Handle, Mask, @Overlapped);
    Signaled := WaitForMultipleObjects(2, @EventHandles, False, INFINITE);
    // if event occurs, dispatch it
    if (Signaled = WAIT_OBJECT_0 + 1)
      and GetOverlappedResult(FComPort.Handle, Overlapped, BytesTrans, False) then
    begin
      FEvents := IntToEvents(Mask);
      DispatchComMsg;
    end;
  until Signaled <> (WAIT_OBJECT_0 + 1);
  // clear buffers
  SetCommMask(FComPort.Handle, 0);
  PurgeComm(FComPort.Handle, PURGE_TXCLEAR or PURGE_RXCLEAR);
  CloseHandle(Overlapped.hEvent);
  CloseHandle(FStopEvent);
end;

// stop thread

procedure TComThread.Stop;
begin
  SetEvent(FStopEvent);
  while Suspended do
    Resume;
  Sleep(0);
end;

// dispatch events

procedure TComThread.DispatchComMsg;
begin
  case FComPort.SyncMethod of
    smThreadSync: Synchronize(DoEvents); // call events in main thread
    smWindowSync: SendEvents; // call events in thread that opened the port
    smNone: DoEvents; // call events inside monitoring thread
  end;
end;

// send events to TCustomSerialPort component using window message

procedure TComThread.SendEvents;
begin
  if evError in FEvents then
    SendMessage(FComPort.FWindow, CM_COMPORT, EV_ERR, 0);
  if evRxChar in FEvents then
    SendMessage(FComPort.FWindow, CM_COMPORT, EV_RXCHAR, 0);
  if evTxEmpty in FEvents then
    SendMessage(FComPort.FWindow, CM_COMPORT, EV_TXEMPTY, 0);
  if evBreak in FEvents then
    SendMessage(FComPort.FWindow, CM_COMPORT, EV_BREAK, 0);
  if evRing in FEvents then
    SendMessage(FComPort.FWindow, CM_COMPORT, EV_RING, 0);
  if evCTS in FEvents then
    SendMessage(FComPort.FWindow, CM_COMPORT, EV_CTS, 0);
  if evDSR in FEvents then
    SendMessage(FComPort.FWindow, CM_COMPORT, EV_DSR, 0);
  if evRxFlag in FEvents then
    SendMessage(FComPort.FWindow, CM_COMPORT, EV_RXFLAG, 0);
  if evRing in FEvents then
    SendMessage(FComPort.FWindow, CM_COMPORT, EV_RLSD, 0);
  if evRx80Full in FEvents then
    SendMessage(FComPort.FWindow, CM_COMPORT, EV_RX80FULL, 0);
end;

// call events

procedure TComThread.DoEvents;
begin
  if evError in FEvents then
    FComPort.CallError;
  if evRxChar in FEvents then
    FComPort.CallRxChar;
  if evTxEmpty in FEvents then
    FComPort.CallTxEmpty;
  if evBreak in FEvents then
    FComPort.CallBreak;
  if evRing in FEvents then
    FComPort.CallRing;
  if evCTS in FEvents then
    FComPort.CallCTSChange;
  if evDSR in FEvents then
    FComPort.CallDSRChange;
  if evRxFlag in FEvents then
    FComPort.CallRxFlag;
  if evRLSD in FEvents then
    FComPort.CallRLSDChange;
  if evRx80Full in FEvents then
    FComPort.CallRx80Full;
end;

(*****************************************
 * TComTimeouts class                    *
 *****************************************)

// create class

constructor TComTimeouts.Create;
begin
  inherited Create;
  FReadInterval := -1;
  FWriteTotalM := 100;
  FWriteTotalC := 1000;
end;

// copy properties to other class

procedure TComTimeouts.AssignTo(Dest: TPersistent);
begin
  if Dest is TComTimeouts then
  begin
    with TComTimeouts(Dest) do
    begin
      FReadInterval := Self.ReadInterval;
      FReadTotalM := Self.ReadTotalMultiplier;
      FReadTotalC := Self.ReadTotalConstant;
      FWriteTotalM := Self.WriteTotalMultiplier;
      FWriteTotalC := Self.WriteTotalConstant;
    end
  end
  else
    inherited AssignTo(Dest);
end;

// select TCustomSerialPort to own this class

procedure TComTimeouts.SetComPort(const AComPort: TCustomSerialPort);
begin
  FComPort := AComPort;
end;

// set read interval

procedure TComTimeouts.SetReadInterval(const Value: Integer);
begin
  if Value <> FReadInterval then
  begin
    FReadInterval := Value;
    // if possible, apply the changes
    if FComPort <> nil then
      FComPort.ApplyTimeouts;
  end;
end;

// set read total constant

procedure TComTimeouts.SetReadTotalC(const Value: Integer);
begin
  if Value <> FReadTotalC then
  begin
    FReadTotalC := Value;
    if FComPort <> nil then
      FComPort.ApplyTimeouts;
  end;
end;

// set read total multiplier

procedure TComTimeouts.SetReadTotalM(const Value: Integer);
begin
  if Value <> FReadTotalM then
  begin
    FReadTotalM := Value;
    if FComPort <> nil then
      FComPort.ApplyTimeouts;
  end;
end;

// set write total constant

procedure TComTimeouts.SetWriteTotalC(const Value: Integer);
begin
  if Value <> FWriteTotalC then
  begin
    FWriteTotalC := Value;
    if FComPort <> nil then
      FComPort.ApplyTimeouts;
  end;
end;

// set write total multiplier

procedure TComTimeouts.SetWriteTotalM(const Value: Integer);
begin
  if Value <> FWriteTotalM then
  begin
    FWriteTotalM := Value;
    if FComPort <> nil then
      FComPort.ApplyTimeouts;
  end;
end;

(*****************************************
 * TComFlowControl class                 *
 *****************************************)

// create class

constructor TComFlowControl.Create;
begin
  inherited Create;
  FXonChar := #17;
  FXoffChar := #19;
end;

// copy properties to other class

procedure TComFlowControl.AssignTo(Dest: TPersistent);
begin
  if Dest is TComFlowControl then
  begin
    with TComFlowControl(Dest) do
    begin
      FOutCTSFlow := Self.OutCTSFlow;
      FOutDSRFlow := Self.OutDSRFlow;
      FControlDTR := Self.ControlDTR;
      FControlRTS := Self.ControlRTS;
      FXonXoffOut := Self.XonXoffOut;
      FXonXoffIn := Self.XonXoffIn;
      FTxContinueOnXoff := Self.TxContinueOnXoff;
      FDSRSensitivity := Self.DSRSensitivity;
      FXonChar := Self.XonChar;
      FXoffChar := Self.XoffChar;
    end
  end
  else
    inherited AssignTo(Dest);
end;

// select TCustomSerialPort to own this class

procedure TComFlowControl.SetComPort(const AComPort: TCustomSerialPort);
begin
  FComPort := AComPort;
end;

// set input flow control for DTR (data-terminal-ready)

procedure TComFlowControl.SetControlDTR(const Value: TDTRFlowControl);
begin
  if Value <> FControlDTR then
  begin
    FControlDTR := Value;
    if FComPort <> nil then
      FComPort.ApplyDCB;
  end;
end;

// set input flow control for RTS (request-to-send)

procedure TComFlowControl.SetControlRTS(const Value: TRTSFlowControl);
begin
  if Value <> FControlRTS then
  begin
    FControlRTS := Value;
    if FComPort <> nil then
      FComPort.ApplyDCB;
  end;
end;

// set ouput flow control for CTS (clear-to-send)

procedure TComFlowControl.SetOutCTSFlow(const Value: Boolean);
begin
  if Value <> FOutCTSFlow then
  begin
    FOutCTSFlow := Value;
    if FComPort <> nil then
      FComPort.ApplyDCB;
  end;
end;

// set output flow control for DSR (data-set-ready)

procedure TComFlowControl.SetOutDSRFlow(const Value: Boolean);
begin
  if Value <> FOutDSRFlow then
  begin
    FOutDSRFlow := Value;
    if FComPort <> nil then
      FComPort.ApplyDCB;
  end;
end;

// set software input flow control

procedure TComFlowControl.SetXonXoffIn(const Value: Boolean);
begin
  if Value <> FXonXoffIn then
  begin
    FXonXoffIn := Value;
    if FComPort <> nil then
      FComPort.ApplyDCB;
  end;
end;

// set software ouput flow control

procedure TComFlowControl.SetXonXoffOut(const Value: Boolean);
begin
  if Value <> FXonXoffOut then
  begin
    FXonXoffOut := Value;
    if FComPort <> nil then
      FComPort.ApplyDCB;
  end;