unidevice_builtin.pas

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

end;

// set DSR sensitivity

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

// set transfer continue when Xoff is sent

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

// set Xon char

procedure TComFlowControl.SetXonChar(const Value: Char);
begin
  if Value <> FXonChar then
  begin
    FXonChar := Value;
    if FComPort <> nil then
      FComPort.ApplyDCB;
  end;
end;

// set Xoff char

procedure TComFlowControl.SetXoffChar(const Value: Char);
begin
  if Value <> FXoffChar then
  begin
    FXoffChar := Value;
    if FComPort <> nil then
      FComPort.ApplyDCB;
  end;
end;

// get common flow control

function TComFlowControl.GetFlowControl: TFlowControl;
begin
  if (FControlRTS = rtsHandshake) and (FOutCTSFlow)
    and (not FXonXoffIn) and (not FXonXoffOut) then
    Result := fcHardware
  else if (FControlRTS = rtsDisable) and (not FOutCTSFlow)
    and (FXonXoffIn) and (FXonXoffOut) then
    Result := fcSoftware
  else if (FControlRTS = rtsDisable) and (not FOutCTSFlow)
    and (not FXonXoffIn) and (not FXonXoffOut) then
    Result := fcNone
  else
    Result := fcCustom;
end;

// set common flow control

procedure TComFlowControl.SetFlowControl(const Value: TFlowControl);
begin
  if Value <> fcCustom then
  begin
    FControlRTS := rtsDisable;
    FOutCTSFlow := False;
    FXonXoffIn := False;
    FXonXoffOut := False;
    case Value of
      fcHardware:
        begin
          FControlRTS := rtsHandshake;
          FOutCTSFlow := True;
        end;
      fcSoftware:
        begin
          FXonXoffIn := True;
          FXonXoffOut := True;
        end;
    end;
  end;
  if FComPort <> nil then
    FComPort.ApplyDCB;
end;

(*****************************************
 * TComParity class                      *
 *****************************************)

// create class

constructor TComParity.Create;
begin
  inherited Create;
  FBits := prNone;
end;

// copy properties to other class

procedure TComParity.AssignTo(Dest: TPersistent);
begin
  if Dest is TComParity then
  begin
    with TComParity(Dest) do
    begin
      FBits := Self.Bits;
      FCheck := Self.Check;
      FReplace := Self.Replace;
      FReplaceChar := Self.ReplaceChar;
    end
  end
  else
    inherited AssignTo(Dest);
end;

// select TCustomSerialPort to own this class

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

// set parity bits

procedure TComParity.SetBits(const Value: TParityBits);
begin
  if Value <> FBits then
  begin
    FBits := Value;
    if FComPort <> nil then
      FComPort.ApplyDCB;
  end;
end;

// set check parity

procedure TComParity.SetCheck(const Value: Boolean);
begin
  if Value <> FCheck then
  begin
    FCheck := Value;
    if FComPort <> nil then
      FComPort.ApplyDCB;
  end;
end;

// set replace on parity error

procedure TComParity.SetReplace(const Value: Boolean);
begin
  if Value <> FReplace then
  begin
    FReplace := Value;
    if FComPort <> nil then
      FComPort.ApplyDCB;
  end;
end;

// set replace char

procedure TComParity.SetReplaceChar(const Value: Char);
begin
  if Value <> FReplaceChar then
  begin
    FReplaceChar := Value;
    if FComPort <> nil then
      FComPort.ApplyDCB;
  end;
end;

(*****************************************
 * TComBuffer class                      *
 *****************************************)

// create class

constructor TComBuffer.Create;
begin
  inherited Create;
  FInputSize := 1024;
  FOutputSize := 1024;
end;

// copy properties to other class

procedure TComBuffer.AssignTo(Dest: TPersistent);
begin
  if Dest is TComBuffer then
  begin
    with TComBuffer(Dest) do
    begin
      FOutputSize := Self.OutputSize;
      FInputSize := Self.InputSize;
    end
  end
  else
    inherited AssignTo(Dest);
end;

// select TCustomSerialPort to own this class

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

// set input size

procedure TComBuffer.SetInputSize(const Value: Integer);
begin
  if Value <> FInputSize then
  begin
    FInputSize := Value;
    if (FInputSize mod 2) = 1 then
      Dec(FInputSize);
    if FComPort <> nil then
      FComPort.ApplyBuffer;
  end;
end;

// set ouput size

procedure TComBuffer.SetOutputSize(const Value: Integer);
begin
  if Value <> FOutputSize then
  begin
    FOutputSize := Value;
    if (FOutputSize mod 2) = 1 then
      Dec(FOutputSize);
    if FComPort <> nil then
      FComPort.ApplyBuffer;
  end;
end;

(*****************************************
 * TCustomSerialPort component              *
 *****************************************)

// create component

constructor TCustomSerialPort.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  // component cannot reside on inheritable forms
  FComponentStyle := FComponentStyle - [csInheritable];
  FTriggersOnRxChar := True;
  FBaudRate := br9600;
  FCustomBaudRate := 9600;
  // Updated by Cheer
  FPort := '';
  FStopBits := sbOneStopBit;
  FDataBits := dbEight;
  FEvents := [evRxChar, evTxEmpty, evRxFlag, evRing, evBreak,
    evCTS, evDSR, evError, evRLSD, evRx80Full];
  FHandle := INVALID_HANDLE_VALUE;
  FStoredProps := [spBasic];
  FParity := TComParity.Create;
  FParity.SetComPort(Self);
  FFlowControl := TComFlowControl.Create;
  FFlowControl.SetComPort(Self);
  FTimeouts := TComTimeouts.Create;
  FTimeouts.SetComPort(Self);
  FBuffer := TComBuffer.Create;
  FBuffer.SetComPort(Self);
  FSem := CreateSemaphore(nil, 1, 1, nil);
end;

// destroy component

destructor TCustomSerialPort.Destroy;
begin
  Close;
  FBuffer.Free;
  FFlowControl.Free;
  FTimeouts.Free;
  FParity.Free;
  CloseHandle(FSem);
  inherited Destroy;
end;

// create handle to serial port

procedure TCustomSerialPort.CreateHandle;
begin
  FHandle := CreateFile(
    PChar('\\.\' + FPort),
    GENERIC_READ or GENERIC_WRITE,
    0,
    nil,
    OPEN_EXISTING,
    FILE_FLAG_OVERLAPPED,
    0);

  if FHandle = INVALID_HANDLE_VALUE then
    raise EComPort.Create(CError_OpenFailed, GetLastError);
end;

// destroy serial port handle

procedure TCustomSerialPort.DestroyHandle;
begin
  if FHandle <> INVALID_HANDLE_VALUE then
    CloseHandle(FHandle);
end;

procedure TCustomSerialPort.Loaded;
begin
  inherited Loaded;
  // open port if Connected is True at design-time
  if (FConnected) and (not (csDesigning in ComponentState)) then
  begin
    FConnected := False;
    try
      Open;
    except
      Application.HandleException(Self);
    end;
  end;
end;

// call events which have been dispatch using window message

procedure TCustomSerialPort.WindowMethod(var Message: TMessage);
begin
  with Message do
    if Msg = CM_COMPORT then
    try
      case wParam of
        EV_RXCHAR: CallRxChar;
        EV_TXEMPTY: CallTxEmpty;
        EV_BREAK: CallBreak;
        EV_RING: CallRing;
        EV_CTS: CallCTSChange;
        EV_DSR: CallDSRChange;
        EV_RXFLAG: CallRxFlag;
        EV_RLSD: CallRLSDChange;
        EV_ERR: CallError;
        EV_RX80FULL: CallRx80Full;
      end
    except
      Application.HandleException(Self);
    end
    else
      Result := DefWindowProc(FWindow, Msg, wParam, lParam);
end;

// prevent from applying changes at runtime

procedure TCustomSerialPort.BeginUpdate;
begin
  FUpdateCount := FUpdateCount + 1;
end;

// apply the changes made since BeginUpdate call

procedure TCustomSerialPort.EndUpdate;
begin
  if FUpdateCount > 0 then
  begin
    FUpdateCount := FUpdateCount - 1;
    if FUpdateCount = 0 then
      SetupComPort;
  end;
end;

// open port

procedure TCustomSerialPort.Open;
begin
  // if already connected, do nothing
  if (not FConnected) and (not (csDesigning in ComponentState)) then
  begin
    CallBeforeOpen;
    // open port
    CreateHandle;
    FConnected := True;
    try
      // initialize port
      SetupComPort;
    except
      // error occured during initialization, destroy handle
      DestroyHandle;
      FConnected := False;
      raise;
    end;
    // if at least one event is set, create special thread to monitor port
    if (FEvents = []) then
      FThreadCreated := False
    else
    begin
      if (FSyncMethod = smWindowSync) then
{$IFDEF VER140}
        FWindow := Classes.AllocateHWnd(WindowMethod);
{$ELSE}
        FWindow := AllocateHWnd(WindowMethod);
{$ENDIF}
      FEventThread := TComThread.Create(Self);
      FThreadCreated := True;
    end;
    // port is succesfully opened, do any additional initialization
    CallAfterOpen;
  end;
end;

// close port

procedure TCustomSerialPort.Close;
begin
  // if already closed, do nothing
  if (FConnected) and (not (csDesigning in ComponentState)) then
  begin
    CallBeforeClose;
    // abort all pending operations
    AbortAllAsync;
    // stop monitoring for events
    if FThreadCreated then
    begin
      FEventThread.Free;
      FThreadCreated := False;
      if FSyncMethod = smWindowSync then
{$IFDEF VER140}
        Classes.DeallocateHWnd(FWindow);
{$ELSE}
        DeallocateHWnd(FWindow);
{$ENDIF}
    end;
    // close port
    DestroyHandle;
    FConnected := False;
    // port is closed, do any additional finalization
    CallAfterClose;
  end;
end;

// apply port properties

procedure TCustomSerialPort.ApplyDCB;
const
  CParityBits: array[TParityBits] of Integer =
  (NOPARITY, ODDPARITY, EVENPARITY, MARKPARITY, SPACEPARITY);
  CStopBits: array[TStopBits] of Integer =
  (ONESTOPBIT, ONE5STOPBITS, TWOSTOPBITS);
  CBaudRate: array[TBaudRate] of Integer =
  (0, CBR_110, CBR_300, CBR_600, CBR_1200, CBR_2400, CBR_4800, CBR_9600,
    CBR_14400, CBR_19200, CBR_38400, CBR_56000, CBR_57600, CBR_115200,
    CBR_128000, CBR_256000);
  CDataBits: array[TDataBits] of Integer = (5, 6, 7, 8);
  CControlRTS: array[TRTSFlowControl] of Integer =
  (RTS_CONTROL_DISABLE shl 12,
    RTS_CONTROL_ENABLE shl 12,
    RTS_CONTROL_HANDSHAKE shl 12,
    RTS_CONTROL_TOGGLE shl 12);
  CControlDTR: array[TDTRFlowControl] of Integer =
  (DTR_CONTROL_DISABLE shl 4,
    DTR_CONTROL_ENABLE shl 4,
    DTR_CONTROL_HANDSHAKE shl 4);

var
  DCB: TDCB;

begin
  // if not connected or inside BeginUpdate/EndUpdate block, do nothing
  if (FConnected) and (FUpdateCount = 0) and
    (not ((csDesigning in ComponentState) or (csLoading in ComponentState))) then
  begin
    DCB.DCBlength := SizeOf(TDCB);
    DCB.XonLim := FBuffer.InputSize div 4;
    DCB.XoffLim := DCB.XonLim;
    DCB.EvtChar := Char(FEventChar);

    DCB.Flags := dcb_Binary;
    if FDiscardNull then
      DCB.Flags := DCB.Flags or dcb_Null;

    with FFlowControl do
    begin
      DCB.XonChar := XonChar;
      DCB.XoffChar := XoffChar;