xcomdrv.pas

delphi串口通讯控件,简单易用

    Result := FParity;
end;

function TCommDataControl.GetStopBits: TStopBits;
var DCB: TDCB;
begin
  if FComm.Opened and GetCommState(FComm.Handle, DCB) then
    Result := TStopBits(DCB.StopBits)
  else
    Result := FStopBits;
end;

procedure TCommDataControl.AssignTo( Dest: TPersistent );
begin
  if Dest is TCommDataControl then
  begin
    FDataBits := TCommDataControl(Dest).DataBits;
    FParity   := TCommDataControl(Dest).Parity;
    FStopBits := TCommDataControl(Dest).StopBits;
    if FComm.Opened and not FComm.FUpdating then
      FComm.UpdateDCB;
  end
   else inherited AssignTo(Dest);
end;

{-- TCommBuffers --}

constructor TCommBuffers.Create( AComm: TCustomComm );
begin
  inherited Create;
  FComm          := AComm;
  FInputSize     := 2048;
  FInputTime     := 500;
  FOutputSize    := 2048;
  FOutputTime    := 500;
end;

procedure TCommBuffers.SetIOSize( Index: integer; Value: word );
var
  CanUpdate: Boolean;
  UpLimit: word;

  function IsWinNT: Boolean;
  var ver: TOSVERSIONINFO;
  begin
    ver.dwOSVersionInfoSize := SizeOf(ver);
    Result := GetVersionEx(ver) and
      (ver.dwPlatformId = VER_PLATFORM_WIN32_NT) and
      (MAKELONG(ver.dwMinorVersion, ver.dwMajorVersion) >= $00040000);
  end;

begin
  if IsWinNT
    then UpLimit := 4096
    else UpLimit := 8192;
  if Value>UpLimit then Value := UpLimit;
  if Value<128 then Value := 128;
  CanUpdate := False;
  case Index of
    0: if FInputSize<>Value then
    begin
      FInputSize   := Value;
      CanUpdate    := True;
    end;
    1: if FOutputSize<>Value then
    begin
      FOutputSize  := Value;
      CanUpdate    := True;
    end;
  end;
  if CanUpdate and FComm.Opened and not FComm.FUpdating then
    FComm.UpdateBuffers;
end;

function TCommBuffers.GetIOSize( Index: integer ): word;
var cp: TCommProp;
begin
  Result := 65535;
  if FComm.Opened and GetCommProperties(FComm.Handle, cp) then
  case Index of
    0: if cp.dwCurrentRXQueue=0
      then Result := FInputSize
      else Result := cp.dwCurrentRXQueue;
    1: if cp.dwCurrentTXQueue=0
      then Result := FInputSize
      else Result := cp.dwCurrentTXQueue;
  end else
  case Index of
    0: Result := FInputSize;
    1: Result := FOutputSize;
  end;
end;

procedure TCommBuffers.AssignTo( Dest: TPersistent );
begin
  if (Dest is TCommBuffers) then
  begin
    FInputTime  := TCommBuffers(Dest).InputTimeout;
    FOutputTime := TCommBuffers(Dest).OutputTimeout;
    FInputSize  := TCommBuffers(Dest).InputSize;
    FOutputSize := TCommBuffers(Dest).OutputSize;
    if FComm.Opened and not FComm.FUpdating then
      FComm.UpdateBuffers;
  end
  else inherited AssignTo(Dest);
end;

{-- TCommEventChars --}

constructor TCommEventChars.Create( AComm: TCustomComm );
begin
  inherited Create;
  FComm          := AComm;
  FXonChar       := #17;
  FXoffChar      := #19;
  FEofChar       := #0;
  FErrorChar     := #0;
  FEventChar     := #10;
end;

procedure TCommEventChars.SetCommChar( Index: integer; Value: char );
var CanUpdate: Boolean;
begin
  CanUpdate := False;
  case Index of
    0: if FXonChar<>Value then
    begin
      FXonChar  := Value;
      CanUpdate := True;
    end;
    1: if FXoffChar<>Value then
    begin
      FXoffChar := Value;
      CanUpdate := True;
    end;
    2: if FEofChar<>Value then
    begin
      FEofChar  := Value;
      CanUpdate := True;
    end;
    3: if FErrorChar<>Value then
    begin
      FErrorChar := Value;
      CanUpdate  := True;
    end;
    4: if FEventChar<>Value then
    begin
      FEventChar := Value;
      CanUpdate  := True;
    end;
  end;
  if CanUpdate and FComm.Opened and not FComm.FUpdating then
    FComm.UpdateDCB;
end;

function TCommEventChars.GetCommChar( Index: integer ): char;
var dcb: TDCB;
begin
  Result := #0;
  if FComm.Opened and GetCommState(FComm.Handle, dcb) then
  case Index of
    0: Result := dcb.XOnChar;
    1: Result := dcb.XOffChar;
    2: Result := dcb.EOfChar;
    3: Result := dcb.ErrorChar;
    4: Result := dcb.EvtChar;
  end else
  case Index of
    0: Result := FXonChar;
    1: Result := FXoffChar;
    2: Result := FEofChar;
    3: Result := FErrorChar;
    4: Result := FEventChar;
  end;
end;

procedure TCommEventChars.AssignTo( Dest: TPersistent );
begin
  if (Dest is TCommEventChars) then
  begin
    FXonChar   := TCommEventChars(Dest).XonChar;
    FXoffChar  := TCommEventChars(Dest).XoffChar;
    FEofChar   := TCommEventChars(Dest).EofChar;
    FErrorChar := TCommEventChars(Dest).ErrorChar;
    FEventChar := TCommEventChars(Dest).EventChar;
    if FComm.Opened and not FComm.FUpdating then
      FComm.UpdateDCB;
  end
  else inherited AssignTo(Dest);
end;

{-- TCommTimeoutsEx --}

constructor TCommTimeoutsEx.Create( AComm: TCustomComm );
begin
  inherited Create;
  FComm             := AComm;
  FReadInterval     := 1;
  FReadMultiplier   := 0;
  FReadConstant     := 1;
  FWriteMultiplier  := 0;
  FWriteConstant    := 1;
end;

procedure TCommTimeoutsEx.SetInterval( Index: integer; Value: DWORD);
var CanUpdate: Boolean;
begin
  CanUpdate := False;
  case Index of
    0: if FReadInterval<>Value then
    begin
      FReadInterval := Value;
      CanUpdate     := True;
    end;
    1: if FReadMultiplier<>Value then
    begin
      FReadMultiplier := Value;
      CanUpdate       := True;
    end;
    2: if FReadConstant<>Value then
    begin
      FReadConstant := Value;
      CanUpdate     := True;
    end;
    3: if FWriteMultiplier<>Value then
    begin
      FWriteMultiplier := Value;
      CanUpdate        := True;
    end;
    4: if FWriteConstant<>Value then
    begin
      FWriteConstant := Value;
      CanUpdate      := True;
    end;
  end;
  if CanUpdate and FComm.Opened and not FComm.FUpdating then
    FComm.UpdateTimeouts;
end;

function TCommTimeoutsEx.GetInterval( Index: integer ): DWORD;
var tms: TCommTimeouts;
begin
  Result := 0;
  if FComm.Opened and GetCommTimeouts(FComm.Handle, tms) then
  case Index of
    0: Result := tms.ReadIntervalTimeout;
    1: Result := tms.ReadTotalTimeoutMultiplier;
    2: Result := tms.ReadTotalTimeoutConstant;
    3: Result := tms.WriteTotalTimeoutMultiplier;
    4: Result := tms.WriteTotalTimeoutConstant;
  end else
  case Index of
    0: Result := FReadInterval;
    1: Result := FReadMultiplier;
    2: Result := FReadConstant;
    3: Result := FWriteMultiplier;
    4: Result := FWriteConstant;
  end;
end;

procedure TCommTimeoutsEx.AssignTo( Dest: TPersistent );
begin
  if (Dest is TCommTimeoutsEx) then
  begin
    FReadInterval    := TCommTimeoutsEx(Dest).ReadInterval;
    FReadMultiplier  := TCommTimeoutsEx(Dest).ReadMultiplier;
    FReadConstant    := TCommTimeoutsEx(Dest).ReadConstant;
    FWriteMultiplier := TCommTimeoutsEx(Dest).WriteMultiplier;
    FWriteConstant   := TCommTimeoutsEx(Dest).WriteConstant;
    if FComm.Opened and not FComm.FUpdating then
      FComm.UpdateTimeouts;
  end
  else inherited AssignTo(Dest);
end;


{-- TCustomComm --}

constructor TCustomComm.Create( AOwner: TComponent );
begin
  inherited Create(AOwner);
  FHandle        := INVALID_HANDLE_VALUE;
  FDeviceName    := 'COM2';
  FBaudRate      := br9600;
  FBaudValue     := 9600;
  FOptions       := [];
  FFlowControl   := fcNone;
  FDataControl   := TCommDataControl.Create(Self);
  FBuffers       := TCommBuffers.Create(Self);
  FEventChars    := TCommEventChars.Create(Self);
  FTimeouts      := TCommTimeoutsEx.Create(Self);
  FTotalRead     := 0;
  FTotalSent     := 0;
  FEvents        := [deChar, deOutEmpty, deFlag];
  FUpdating      := False;
  FRTSSettings   := [];
  FDTRSettings   := [];
  FXOnXOffSettings := [];
  FSynchronize   := True;
  FPlugins       := TList.Create;
  FPaused        := 0;
end;

destructor TCustomComm.Destroy;
begin
  if Opened then
  begin
{$IFDEF X_DEBUG}
    if not (csDesigning in ComponentState) then
{$ENDIF}
    FCommThread.Free;
    CloseHandle(FHandle);
    FHandle:=INVALID_HANDLE_VALUE;  // Bigmike 2001.04.27
  end;
  FDataControl.Free;
  FBuffers.Free;
  FEventChars.Free;
  FTimeouts.Free;
  ClearPlugins;
  FPlugins.Free;
  inherited Destroy;
end;

procedure TCustomComm.SetDeviceName( Value: string );
begin
  if not Opened and (FDeviceName<>Value) then
    FDeviceName:=Value;
end;

procedure TCustomComm.SetDataControl( Value: TCommDataControl );
begin
  if (Value<>FDataControl) then
    FDataControl.Assign(Value);
end;

procedure TCustomComm.SetBuffers( Value: TCommBuffers );
begin
  if (Value<>FBuffers) then
    FBuffers.Assign(Value);
end;

procedure TCustomComm.SetEventChars( Value: TCommEventChars);
begin
   if (Value<>FEventChars) then
    FEventChars.Assign(Value);
end;

procedure TCustomComm.SetTimeouts( Value: TCommTimeoutsEx );
begin
   if (Value<>FTimeouts) then
    FTimeouts.Assign(Value);
end;

procedure TCustomComm.SetBaudRate(Value: TBaudRate);
begin
  if (FBaudRate<>Value) then
  begin
    FBaudRate := Value;
    if (Value<>brCustom) then
    begin
      FBaudValue := BAUDRATE_[Value];
      if Opened and not FUpdating then UpdateDCB;
    end;
  end;
end;

procedure TCustomComm.SetBaudValue( Value: DWORD );
begin
  if (FBaudRate=brCustom) and (Value<>FBaudValue) then
  begin
    FBaudValue := Value;
    if Opened and not FUpdating then UpdateDCB;
  end;
end;

procedure TCustomComm.SetFlowControl( Value: TFlowControl );
begin
  if (Value<>FlowControl) then
  begin
    FFlowControl := Value;
    if (Value<>fcCustom) then
    begin
      UpdateFlowSettings(0);
      if Opened and not FUpdating then UpdateDCB;
    end;
  end;
end;

procedure TCustomComm.SetRTSSettings( Value: TRTSSettings );
begin
  if (FFlowControl=fcCustom) and (Value<>RTSSettings) then
  begin
    FRTSSettings := Value;
    if Opened and not FUpdating then UpdateDCB;
  end;
end;

procedure TCustomComm.SetDTRSettings( Value: TDTRSettings );
begin
{$IFNDEF OLDFLOW}
  if (coLeaveDTROpen in FOptions) then
  begin
    Exclude(Value, fsDTRHandshake);
    Include(Value, fsDTREnabled);
  end;
  if (fsDTRhandshake in Value) and (fsDTREnabled in Value) then
  begin
    if (fsDTRhandshake in FDTRSettings)
      then Exclude(Value, fsDTRhandshake)
      else Exclude(Value, fsDTREnabled);
  end;
{$ENDIF}
  if (FFlowControl=fcCustom) and (Value<>DTRSettings) then
  begin
    FDTRSettings := Value;
    if Opened and not FUpdating then UpdateDCB;
  end;
end;

procedure TCustomComm.SetXOnXOffSettings( Value: TXOnXOffSettings );
begin
  if (FFlowControl=fcCustom) and (Value<>XOnXOffSettings) then
  begin
    FXOnXOffSettings := Value;
    if Opened and not FUpdating then UpdateDCB;
  end;