xcomdrv.pas

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

    function GetInstalled: boolean;
    function GetConnected: boolean;
    function GetLineStatus: TLineStatus;
    function GetModemState: TModemState;
    function GetEnterCmd: string;
  protected
    procedure ReceiveData( Received: DWORD ); override;
    procedure HandleEvents( Events: TDeviceEvents ); override;
    function GetLocked: TLockState; override;
    procedure HandleAT( AT: THayesAT ); dynamic;
    procedure DoConnect; virtual;
    procedure DoDisconnect; virtual;
    procedure DoConnecting( ConnectType: TConnectType ); virtual;
    procedure DoDisconnecting; virtual;
    procedure DoChangeCmdState; virtual;
  public
    property Connected: boolean read GetConnected;
    property Installed: boolean read GetInstalled;
    property LineStatus: TLineStatus read GetLineStatus;
    property ModemState: TModemState read GetModemState;

    constructor Create( AOwner: TComponent ); override;
    destructor Destroy; override;

    function OpenDevice: boolean; override;
    procedure CloseDevice; override;

    function ResetModem: boolean;
    function InitModem: boolean;
    function Connect(WaitResult: boolean): boolean;
    procedure Disconnect;
    procedure LowerDTR;

    function SendCommand( const Value: string ): boolean;
    function SetRegisterValue( Reg, Value: byte ): boolean;
    function GetRegisterValue( Reg: byte; var Value: byte ): boolean;

    function EnterCommandState: boolean;
    function ExitCommandState: boolean;

    function WaitForAT( Timeout: DWORD ): THayesAT;
  protected
    property ModemSettings    : TModemSettings read FModemSettings write SetModemSettings;
    property OnHayesAT        : THayesATEvent read FOnHayesAT write FOnHayesAT;
    property OnConnect        : TNotifyEvent read FOnConnect write FOnConnect;
    property OnConnecting     : TConnectingEvent read FOnConnecting write FOnConnecting;
    property OnDisconnect     : TNotifyEvent read FOnDisconnect write FOnDisconnect;
    property OnDisconnecting  : TNotifyEvent read FOnDisconnecting write FOnDisconnecting;
    property OnRing           : TNotifyEvent read FOnRing write FOnRing;
    property OnChangeCmdState : TNotifyEvent read FOnChangeCS write FOnChangeCS;
  end;

  TXModem = class( TCustomModem )
  published
    property BaudRate;
    property BaudValue;
    property Buffers;
    property RTSSettings;
    property DataControl;
    property DeviceName;
    property DTRSettings;
    property EventChars;
    property MonitorEvents;
    property FlowControl;
    property ModemSettings;
    property Options;
    property Synchronize;
    property Timeouts;
    property XOnXOffSettings;

    property OnChangeCmdState;
    property OnCommEvent;
    property OnConnect;
    property OnConnecting;
    property OnData;
    property OnDisconnect;
    property OnDisconnecting;
    property OnHayesAT;
    property OnRead;
    property OnRing;
    property OnSend;

    {$IFDEF X_DEBUG}
    property Opened;
    {$ENDIF}
  end;

function GetRXTimeout( const Baud, DataSize: DWORD ): DWORD;

function DataBitsToChar( const DataBits: TDataBits ): char;
function CharToDataBits( const ch: char ): TDataBits;
function StopBitsToStr( const StopBits: TStopBits ): string;
function StrToStopBits( const Str: string ): TStopBits;

function FlowControlToStr( const fc: TFlowControl ): string;
function StrToFlowControl( const Str: string ): TFlowControl;

function ParityToStr( const Parity: TParity ): string;
function StrToParity( const Str: string ): TParity;

function BaudRateToStr( const BaudRate: TBaudRate ): string;
function StrToBaudRate( const Str: string ): TBaudRate;

function GetTickCount: DWORD;

const
  {Modem int results}
  ME_INVALID       = -1;
  ME_OK            = $0000;
  ME_CONNECT       = $0001;
  ME_RING          = $0002;
  ME_NOCARRIER     = $0003;
  ME_ERROR         = $0004;
  ME_NODIALTONE    = $0005;
  ME_BUSY          = $0006;
  ME_NOANSWER      = $0007;
  ME_UNKNOWN       = $FFFF;

  MB_MINBAUD = 300;

  STR_FLOWCONTROL : array [TFlowControl] of string =
    ( 'None', 'CTS/RTS', 'DTR/DSR', 'XOn/XOff', 'Custom' );
  STR_PARITY : array [TParity] of string =
    ( 'None', 'Odd', 'Even', 'Mark', 'Space' );
  STR_STOPBITS : array [TStopBits] of string =
    ( '1', '1.5', '2' );


function ATShortToLong( var s: string ): boolean;
function ATResultToME( s: string ): integer;

implementation
uses XComErr;

const
  BaudRate_: array[br110..br256000] of DWORD =
    (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);

  dcb_Binary              = $00000001;
  dcb_ParityCheck         = $00000002;
  dcb_OutxCtsFlow         = $00000004;
  dcb_OutxDsrFlow         = $00000008;
  dcb_DtrControlEnable    = $00000010;
  dcb_DtrControlHandshake = $00000020;
  dcb_DsrSensitivity      = $00000040;
  dcb_TXContinueOnXoff    = $00000080;
  dcb_OutX                = $00000100;
  dcb_InX                 = $00000200;
  dcb_ErrorChar           = $00000400;
  dcb_DiscardNull         = $00000800;
  dcb_RtsControlEnable    = $00001000;
  dcb_RtsControlHandshake = $00002000;
  dcb_AbortOnError        = $00004000;
{$IFDEF OLDFLOW}
  dcb_DtrDsrControl       = dcb_Binary or dcb_OutxDsrFlow or dcb_DtrControlEnable or dcb_DtrControlHandshake;
  dcb_RtsCtsControl       = dcb_Binary or dcb_OutxCtsFlow or dcb_RtsControlEnable or dcb_RtsControlHandshake;
  dcb_XOnXOffControl      = dcb_Binary or dcb_InX or dcb_OutX;
{$ELSE}
  dcb_DtrDsrControl       = dcb_Binary or dcb_OutxDsrFlow or dcb_DtrControlEnable or dcb_RtsControlEnable;
  dcb_RtsCtsControl       = dcb_Binary or dcb_OutxCtsFlow or dcb_RtsControlHandshake or dcb_DtrControlEnable;
  dcb_XOnXOffControl      = dcb_Binary or dcb_InX or dcb_OutX or dcb_DtrControlEnable;
{$ENDIF}
  EV_COMMEVENTS = $1FFB;

procedure ConvertErrorFmt( const Ident: string; const Args: array of const );
begin
  raise EConvertError.CreateFmt(Ident, Args);
end;

function GetRXTimeout( const Baud, DataSize: DWORD ): DWORD;
begin
  Result := Round(DataSize/Baud*10000)+1;
end;

function DataBitsToChar( const DataBits: TDataBits ): char;
begin
  Result := Char(ord(DataBits)+52);
end;

{$WARNINGS OFF}
function CharToDataBits( const ch: char ): TDataBits;
begin
  if (ch in ['4'..'8'])
    then Result := TDataBits(byte(ch)-52)
    else ConvertErrorFmt(SInvalidDataBits, [ch]);
end;

function StopBitsToStr( const StopBits: TStopBits ): string;
begin
  Result := STR_STOPBITS[StopBits];
end;

function StrToStopBits( const Str: string ): TStopBits;
begin
  for Result := sb1 to sb2 do
    if Str=STR_STOPBITS[Result] then Exit;
  ConvertErrorFmt(SInvalidStopBits, [Str]);
end;

function FlowControlToStr( const fc: TFlowControl ): string;
begin
  Result := STR_FLOWCONTROL[fc];
end;

function StrToFlowControl( const Str: string ): TFlowControl;
begin
  for Result := fcNone to fcSoftware do
    if UpperCase(Str)=UpperCase(STR_FLOWCONTROL[Result]) then Exit;
  ConvertErrorFmt(SInvalidFlowControl, [Str]);
end;

function ParityToStr( const Parity: TParity ): string;
begin
  Result := STR_PARITY[Parity];
end;

function StrToParity( const Str: string ): TParity;
begin
  for Result := paNone to paSpace do
    if UpperCase(Str)=UpperCase(STR_PARITY[Result]) then Exit;
  ConvertErrorFmt(SInvalidParity, [Str]);
end;

function BaudRateToStr(const BaudRate: TBaudRate): string;
begin
  if (BaudRate<>brCustom)
    then Result := IntToStr(BAUDRATE_[BaudRate])
    else Result := '';
end;

function StrToBaudRate(const Str: string): TBaudRate;
var i: integer;
begin
  for Result := br110 to br256000 do
    if (Str=IntToStr(BAUDRATE_[Result])) then Exit;
  Result := brCustom;
  if (Str='')
    then i := 0
    else i := 1;
  while (i>0) and (i<=Length(Str)) do
    if (Str[i] in ['0'..'9'])
      then Inc(i)
      else i := 0;
  if (i=0) then ConvertErrorFmt(SInvalidBaudRate, [Str]);
end;
{$WARNINGS ON}

procedure SetDCB(var DCB: TDCB);
begin
  FillChar(DCB, SizeOf(DCB), 0);
  DCB.DCBLength := SizeOf(DCB);
end;

function GetCommState(Handle: HFILE; var DCB: TDCB): Boolean;
begin
  SetDCB(DCB);
  Result := Windows.GetCommState(Handle, DCB);
end;

type
  TCommEventThread = class( TThread )
  private
    FStopEvent       : THandle;
    FEventMask       : DWORD;
    FComm            : TCustomComm;
  protected
    procedure Execute; override;
    procedure DoOnSignal;
  public
    constructor Create( AComm: TCustomComm ); virtual;
    destructor Destroy; override;
  end;

{-- TCommEventThread --}

constructor TCommEventThread.Create( AComm: TCustomComm );
begin
  inherited Create(True);
  FComm          := AComm;
  FStopEvent     := CreateEvent(nil, True, False, nil);
  SetCommMask(FComm.Handle, EV_COMMEVENTS);
  Resume;
end;

destructor TCommEventThread.Destroy;
begin
  SetEvent(FStopEvent);
  Sleep(0);
  inherited Destroy;
end;

procedure TCommEventThread.Execute;
var
  EventHandles: array [0..1] of THandle;
  Overlapped: TOverlapped;
  Signaled, BytesTrans: DWORD;
begin
  FillChar(Overlapped, SizeOf(Overlapped), 0);
  Overlapped.hEvent := CreateEvent(nil, True, True, nil);
  EventHandles[0] := FStopEvent;
  EventHandles[1] := Overlapped.hEvent;
  repeat
    WaitCommEvent(FComm.Handle, FEventMask, @Overlapped);
    Signaled := WaitForMultipleObjects(2, @EventHandles, False, INFINITE);
    case Signaled of
      WAIT_OBJECT_0 + 1:
        if GetOverlappedResult(FComm.Handle, Overlapped, BytesTrans, False) then
        begin
          if FComm.Synchronize
            then Synchronize(DoOnSignal)
            else DoOnSignal;
        end else Break;
      else Break;
    end;
  until False;
  SetCommMask(FComm.Handle, 0);
  CloseHandle(Overlapped.hEvent);
  CloseHandle(FStopEvent);
end;

procedure TCommEventThread.DoOnSignal;
begin
  if (FEventMask<>0) and (FComm<>nil) then
    FComm.UpdateEvents(TDeviceEvents(Word(FEventMask)));
end;

{-- TCommPlugin --}

constructor TCommPlugin.Create( AOwner: TComponent );
begin
  inherited Create(AOwner);
  FComm := nil;
  EventState := [esBefore];
  LockState := [];
end;

destructor TCommPlugin.Destroy;
begin
  SetComm(nil);
  inherited Destroy;
end;

procedure TCommPlugin.HandleEvents( var Events: TDeviceEvents );
begin
end;

procedure TCommPlugin.Notification( AComponent: TComponent;
  Operation: TOperation );
begin
  if (Operation=opRemove) and (AComponent=FComm) then FComm := nil;
end;

procedure TCommPlugin.SetComm( Value: TCustomComm );
begin
  if (Value<>FComm) then
  begin
    if (FComm<>nil) then FComm.RemovePlugin(Self);
    if (Value<>nil) then Value.AddPlugin(Self);
    FComm := Value;
  end;
end;

function TCommPlugin.CommValid: boolean;
begin
  Result := FComm<>nil;
  if not Result then XCommError(SNoDevice, DEC_NODEVICE);
end;

{-- TCommDataControl --}

constructor TCommDataControl.Create( AComm: TCustomComm );
begin
  inherited Create;
  FComm          := AComm;
  FDataBits      := db8;
  FParity        := paNone;
  FStopBits      := sb1;
end;

procedure TCommDataControl.SetDataBits( Value: TDataBits );
begin
  if Value<>FDataBits then
  begin
    FDataBits := Value;
    if FComm.Opened and not FComm.FUpdating then
      FComm.UpdateDCB;
  end;
end;

procedure TCommDataControl.SetParity( Value: Tparity );
begin
  if Value<>FParity then
  begin
    FParity := Value;
    if FComm.Opened and not FComm.FUpdating then
      FComm.UpdateDCB;
  end;
end;

procedure TCommDataControl.SetStopBits( Value: TStopBits );
begin
  if Value<>FStopBits then
  begin
    FStopBits := Value;
    if FComm.Opened and not FComm.FUpdating then
      FComm.UpdateDCB;
  end;
end;

function TCommDataControl.GetDataBits: TDataBits;
var DCB: TDCB;
begin
  if FComm.Opened and GetCommState(FComm.Handle, DCB) then
    Result := TDataBits(DCB.ByteSize-(8+Ord(db8)))
  else
    Result := FDataBits;
end;

function TCommDataControl.GetParity: TParity;
var DCB: TDCB;
begin
  if FComm.Opened and GetCommState(FComm.Handle, DCB) then
    Result := TParity(DCB.Parity)
  else