xcomdrv.pas

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

end;

procedure TCustomComm.UpdateFlowSettings( Flags: Integer );
begin
  if (Flags=0) or (not Opened and (FFlowControl<>fcCustom)) then
  begin
    FXOnXOffSettings := [];
    FRTSSettings := [];
    FDTRSettings := [];
{$IFDEF OLDFLOW}
    case FFlowControl of
      fcSoftware: FXOnXOffSettings := [fsInX, fsOutX];
      fcRtsCts: FRTSSettings := [fsCTSOut, fsRTSEnabled, fsRTSHandshake];
      fcDtrDsr: FDTRSettings := [fsDSROut, fsDTREnabled, fsDTRHandshake];
    end;
{$ELSE}
    case FFlowControl of
      fcSoftware: FXOnXOffSettings := [fsInX, fsOutX];
      fcRtsCts: FRTSSettings := [fsCTSOut, fsRTSHandshake];
      fcDtrDsr:
      begin
        FDTRSettings := [fsDSROut];
        FRTSSettings := [fsRTSEnabled];
      end;
    end;
    if (FFlowControl<>fcNone) then Include(FDTRSettings, fsDTREnabled);
    if (coLeaveDTROpen in FOptions) then
    begin
      Include(FDTRSettings, fsDTREnabled);
      Exclude(FDTRSettings, fsDTRHandshake);
    end;
{$ENDIF}
  end else if Opened then
  begin
    FDTRSettings := [];
    if (Flags and dcb_DTRControlHandshake<>0) then Include(FDTRSettings, fsDTRHandshake);
    if (Flags and dcb_DTRControlEnable<>0) then Include(FDTRSettings, fsDTREnabled);
    if (Flags and dcb_OutXDSRFlow<>0) then Include(FDTRSettings, fsDSROut);
    FRTSSettings := [];
    if (Flags and dcb_RTSControlHandshake<>0) then Include(FRTSSettings, fsRTSHandshake);
    if (Flags and dcb_RTSControlEnable<>0) then Include(FRTSSettings, fsRTSEnabled);
    if (Flags and dcb_OutXCTSFlow<>0) then Include(FRTSSettings, fsCTSOut);
    FXOnXOffSettings := [];
    if (Flags and dcb_OutX<>0) then Include(FXOnXOffSettings, fsOutX);
    if (Flags and dcb_InX<>0) then Include(FXOnXOffSettings, fsInX);
    if (coLeaveDTROpen in FOptions)
      then FOptions := [coLeaveDTROpen]
      else FOptions := [];
    if (Flags and dcb_ParityCheck<>0) then Include(FOptions, coParityCheck);
    if (Flags and dcb_DsrSensitivity<>0) then Include(FOptions, coDSRSensitivity);
    if (Flags and dcb_ErrorChar<>0) then Include(FOptions, coErrorChar);
    if (Flags and dcb_DiscardNull<>0) then Include(FOptions, coDiscardNull);
    if (Flags and dcb_AbortOnError<>0) then Include(FOptions, coAbortOnError);
    if (Flags and dcb_TXContinueOnXoff<>0) then Include(FOptions, coTXContinueOnXoff);
  end;
end;

procedure TCustomComm.SetCommOptions( Value: TCommOptions );
begin
  if Opened then
  begin
    if (coLeaveDTROpen in FOptions)
      then Include(Value, coLeaveDTROpen)
      else Exclude(Value, coLeaveDTROpen);
  end;
  if (Options<>Value) then
  begin
    FOptions := Value;
    if not Opened then UpdateFlowSettings(0)
    else if not FUpdating then UpdateDCB;
  end;
end;

function TCustomComm.GetBaudRate: TBaudRate;
var
  I: TBaudRate;
  Value: DWORD;
begin
  if Opened and (FBaudRate<>brCustom) then
  begin
    FBaudRate := brCustom;
    Value := GetBaudValue;
    for I:=br110 to br256000 do
      if BaudRate_[I]=Value then
      begin
        FBaudRate := I;
        Break;
      end;
  end;
  Result := FBaudRate;
end;

function TCustomComm.GetBaudValue: DWORD;
var DCB: TDCB;
begin
  if Opened and GetCommState(Handle, DCB)
    then Result := DCB.BaudRate
    else Result := FBaudValue;
  FBaudValue := Result;
end;

function TCustomComm.GetRTSSettings: TRTSSettings;
var DCB: TDCB;
begin
  if Opened and GetCommState(Handle, DCB) then
    UpdateFlowSettings(DCB.Flags);
  Result := FRTSSettings;
end;

function TCustomComm.GetDTRSettings: TDTRSettings;
var DCB: TDCB;
begin
  if Opened and GetCommState(Handle, DCB) then
    UpdateFlowSettings(DCB.Flags);
  Result := FDTRSettings;
end;

function TCustomComm.GetXOnXOffSettings: TXOnXOffSettings;
var DCB: TDCB;
begin
  if Opened and GetCommState(Handle, DCB) then
    UpdateFlowSettings(DCB.Flags);
  Result := FXOnXOffSettings;
end;

{function TCustomComm.GetFlowControl: TFlowControl;
var DCB: TDCB;
begin
  if Opened and GetCommState(Handle, DCB) then
    UpdateFlowSettings(DCB.Flags);
  Result := FFlowControl;
end;}

function TCustomComm.GetCommOptions: TCommOptions;
var DCB: TDCB;
begin
  if Opened and GetCommState(Handle, DCB) then
    UpdateFlowSettings(DCB.Flags);
  Result := FOptions;
end;

{Plugin support}
procedure TCustomComm.AddPlugin( Value: TCommPlugin );
begin
  FPlugins.Add(Value);
end;

procedure TCustomComm.RemovePlugin( Value: TCommPlugin );
begin
  FPlugins.Remove(Value);
end;

function TCustomComm.GetPlugin( Index: integer ): TCommPlugin;
begin
  Result := TCommPlugin(FPlugins.Items[Index]);
end;

function TCustomComm.GetPluginCount: integer;
begin
  Result := FPlugins.Count;
end;

procedure TCustomComm.ClearPlugins;
begin
  while (FPlugins.Count>0) do
    Plugins[0].SetComm(nil);
end;

function TCustomComm.UpdateDCB: Boolean;
var dcb: TDCB;
begin
  SetDCB(dcb);

  dcb.Flags                  := dcb_Binary;
  if fsDSROut in FDTRSettings then
    dcb.Flags                := dcb.Flags or dcb_OutxDsrFlow;
  if fsDTREnabled in FDTRSettings then
    dcb.Flags                := dcb.Flags or dcb_DtrControlEnable;
  if fsDTRHandshake in FDTRSettings then
    dcb.Flags                := dcb.Flags or dcb_DtrControlHandshake;

  if fsCTSOut in FRTSSettings then
    dcb.Flags                := dcb.Flags or dcb_OutxCtsFlow;
  if fsRTSEnabled in FRTSSettings then
    dcb.Flags                := dcb.Flags or dcb_RtsControlEnable;
  if fsRTSHandshake in FRTSSettings then
    dcb.Flags                := dcb.Flags or dcb_RtsControlHandshake;

  if fsInX in FXOnXOffSettings then
    dcb.Flags                := dcb.Flags or dcb_InX;
  if fsOutX in FXOnXOffSettings then
    dcb.Flags                := dcb.Flags or dcb_OutX;

  dcb.XONLim                 := FBuffers.FInputSize div 4;
  dcb.BaudRate               := FBaudValue;
  dcb.XOFFLim                := dcb.XONLim;
  dcb.ByteSize               := 8-Ord(db8)+Ord(FDataControl.FDataBits);
  dcb.Parity                 := ord(FDataControl.FParity);
  dcb.StopBits               := ord(FDataControl.FStopBits);
  dcb.XONChar                := FEventChars.FXOnChar;
  dcb.XOFFChar               := FEventChars.FXOffChar;
  dcb.EvtChar                := FEventChars.FEventChar;
  dcb.ErrorChar              := FEventChars.FErrorChar;
  dcb.EofChar                := FEventChars.FEofChar;

  if (coParityCheck in FOptions) then
    dcb.Flags                := dcb.Flags or dcb_ParityCheck;
  if (coDsrSensitivity in FOptions) then
    dcb.Flags                := dcb.Flags or dcb_DsrSensitivity;
  if (coErrorChar in FOptions) then
    dcb.Flags                := dcb.Flags or dcb_ErrorChar;
  if (coDiscardNull in FOptions) then
    dcb.Flags                := dcb.Flags or dcb_DiscardNull;
  if (coAbortOnError in FOptions) then
    dcb.Flags                := dcb.Flags or dcb_AbortOnError;
  if (coTXContinueOnXoff in FOptions) then
    dcb.Flags                := dcb.Flags or dcb_TXContinueOnXoff;
  if (coLeaveDTROpen in FOptions) then
    dcb.Flags                := dcb.Flags or dcb_DtrControlEnable;

  Result := SetCommState(FHandle, dcb);
  if not Result then XCommError(SInvalidDCB, DEC_INVALIDDCB);
end;

function TCustomComm.UpdateBuffers: boolean;
begin
  PurgeComm(FHandle, PURGE_TXCLEAR or PURGE_TXABORT or PURGE_RXCLEAR or PURGE_RXABORT);
  Result := SetupComm(FHandle, FBuffers.FInputSize, FBuffers.FOutputSize);
  if not Result then XCommError(SInvalidIOSize, DEC_INVALIDIOSIZE);
end;

function TCustomComm.UpdateTimeouts: boolean;
var tms: TCommTimeouts;
begin
  with FTimeouts, tms do
  begin
    ReadIntervalTimeout := FReadInterval;
    ReadTotalTimeoutMultiplier := FReadMultiplier;
    ReadTotalTimeoutConstant := FReadConstant;
    WriteTotalTimeoutMultiplier := FWriteMultiplier;
    WriteTotalTimeoutConstant := FWriteConstant;
  end;
  Result := SetCommTimeouts(FHandle, tms);
  if not Result then XCommError(SInvalidTimeouts, DEC_INVALIDTIMEOUTS);
end;

function TCustomComm.OpenDevice: boolean;
begin
  Result := not Opened;
  if not Result then
  begin
    XCommError(SCommOpened, DEC_OPENED);
    exit;
  end;
  FLocked := [];
  FPaused := 0;
  FUpdating := False;
  FHandle := CreateFile( pchar('\\.\'+FDeviceName),
                         GENERIC_READ or GENERIC_WRITE,
                         0,
                         nil,
                         OPEN_EXISTING,
                         FILE_FLAG_OVERLAPPED or FILE_ATTRIBUTE_NORMAL,
                         0
                        ) ;
  Result := Opened;
  if not Result then
  begin
    XCommError(Format(SDOpenError, [FDeviceName]), DEC_OPENERROR);
    Exit;
  end;
  {$IFDEF X_DEBUG}
  if not (csDesigning in ComponentState) then
  {$ENDIF}
  FCommThread := TCommEventThread.Create(Self);

  UpdateDCB;
  UpdateBuffers;
  UpdateTimeouts;
end;

procedure TCustomComm.BeginUpdate;
begin
  if not Opened
    then XCommError(SCommOpened, DEC_CLOSED)
    else FUpdating := True;
end;

function TCustomComm.EndUpdate: Boolean;
begin
  Result := False;
  if not Opened then XCommError(SCommOpened, DEC_CLOSED)
  else if FUpdating then
  begin
    FUpdating := False;
    Result := UpdateDCB and UpdateBuffers and UpdateTimeouts;
  end;
end;

procedure TCustomComm.CloseDevice;
begin
  if Opened then
  begin
    {$IFDEF X_DEBUG}
    if not (csDesigning in ComponentState) then
    {$ENDIF}
    FCommThread.Free;
    CloseHandle(FHandle);
    FHandle     := INVALID_HANDLE_VALUE;
    FTotalRead  := 0;
    FTotalSent  := 0;
    FPaused     := 0;
  end else XCommError(SCommClosed, DEC_CLOSED);
end;

{$IFDEF X_DEBUG}
procedure TCustomComm.SetOpened( Value: Boolean );
begin
  if Value and not Opened then OpenDevice
  else if not Value and Opened then CloseDevice
end;
{$ENDIF}

function TCustomComm.GetOpened: boolean;
begin
  Result := FHandle <> INVALID_HANDLE_VALUE;
end;

function TCustomComm.GetPaused: boolean;
begin
  Result := not Opened or (FPaused<>0);
end;

procedure TCustomComm.SetPaused( Value: boolean );
begin
  if Opened then
  begin
    if Value then Inc(FPaused)
    else if (FPaused>0) then Dec(FPaused);
  end;
end;

function TCustomComm.PurgeIn: boolean;
begin
  Result := False;
  if Opened then
  begin
    Inc(FTotalRead, InCount);
    Result := PurgeComm(FHandle, PURGE_RXABORT or PURGE_RXCLEAR);
  end else XCommError(SCommClosed, DEC_CLOSED);
end;

function TCustomComm.PurgeOut: boolean;
begin
  Result := False;
  if Opened
    then Result := PurgeComm(FHandle, PURGE_TXABORT or PURGE_TXCLEAR)
    else XCommError(SCommClosed, DEC_CLOSED);
end;

function TCustomComm.GetTotalReceived: DWORD;
begin
  if Opened
    then Result := FTotalRead + DWORD(InCount)
    else Result := 0;
end;

function TCustomComm.GetCommStatus: TCommStatus;
var ComStat: TCOMSTAT;
    e: DWORD;
begin
  if Opened then
  begin
    if ClearCommError(FHandle, e, @ComStat) then
      Result := TCommStatus(ComStat.Flags)
  end else
  begin
    Result := [];
    XCommError(SCommClosed, DEC_CLOSED);
  end;
end;

function TCustomComm.GetMaxBaud: TBaudRate;
var cp: TCommProp;
begin
  Result := br110;
  if Opened then
  begin
    GetCommProperties(Handle, cp);
    case cp.dwMaxBaud of
      BAUD_300: Result := br300;
      BAUD_600: Result := br600;
      BAUD_1200, BAUD_1800: Result := br1200;
      BAUD_2400: Result := br2400;
      BAUD_4800, BAUD_7200: Result := br4800;
      BAUD_9600: Result := br9600;
      BAUD_14400: Result := br14400;
      BAUD_19200: Result := br19200;
      BAUD_38400: Result := br38400;
      BAUD_56K: Result := br56000;
      BAUD_57600: Result := br57600;
      BAUD_115200: Result := br115200;
      BAUD_128K: Result := br128000;
      BAUD_USER: Result := brCustom;
    end;
  end else XCommError(SCommClosed, DEC_CLOSED);
end;

function TCustomComm.GetCount( Index: integer ): DWORD;
var
  stat: TCOMSTAT;
  errs: DWORD;
begin
  Result := 0;
  if Opened then
  begin
    ClearCommError(FHandle, errs, @stat);
    case Index of
      0: Result := DWORD(stat.cbInQue);
      1: Result := DWORD(stat.cbOutQue);
    end;
  end else XCommError(SCommClosed, DEC_CLOSED);
end;

{===> Alex}
function intSend(Handle: THandle; const Buffer; Count: dword): dword;