port.pas

串口通讯控件。先把 Pcomm.dll 文件拷贝到OS能找得到的目录下。 在Component菜单下选择Install Component子菜单

{ *********************************************************************** }
{                                                                         }
{                          串口通讯组件                                   }
{                                                                         }
{                          作者 : 韦修毅                                  }
{                          Email: [e-mail]                          }
{ *********************************************************************** }

unit Port;         

interface
                           
uses
  Windows, Messages, SysUtils,Forms, Classes,PComm,TypInfo;
const
  { error code }
  SIO_OK           = 0;
  SIO_BADPORT      = -1;  { No such port or port not opened }
  SIO_OUTCONTROL   = -2;  { Can't control board }
  SIO_NODATA       = -4;  { No data to read or no buffer to write }
  SIO_OPENFAIL     = -5;   { No such port or port has opened }
  SIO_RTS_BY_HW    = -6;  { Can't set because H/W flowctrl }
  SIO_BADPARM      = -7;  { Bad parameter }
  SIO_WIN32FAIL    = -8;  (* Call win32 function fail, please call }
                             GetLastError to get the error code *)
  SIO_BOARDNOTSUPPORT  = -9;  { Board does not support this function}
  SIO_FAIL         = -10; { PComm function run result fail }
  SIO_ABORT_WRITE  = -11; { Write has blocked, and user abort write }
  SIO_WRITETIMEOUT = -12; { Write timeout has happened }

  BaudRateConst:array[0..19] of integer=(50,75,110,134,150,300,600,
       1200,1800,2400,4800,7200,9600,19200,38400,57600,115200,230400,
       460800,921600);
type
  TBaudRate = (br50,br75,br110, br134,br150,br300, br600, br1200, br1800,
  br2400, br4800,br7200,br9600,br19200, br38400, br57600, br115200,br230400,
  br460800,br921600 );
  TStopBits = (sbOneStopBit,sbTwoStopBits);
  TDataBits = (dbFive, dbSix, dbSeven, dbEight);
  TParityBits = (prNone, prOdd, prEven, prMark, prSpace);
  TFlushBuffer=(FBInput,FBOutput,FBTow);
  TLineStatus=(lsCTS,lsDSR,lsRING,lsRLSD);
  TRxCharEvent = procedure(Sender: TObject; InQue: Integer) of object;
  TPort = class(TComponent)
  private
    FPortOpened:boolean;
    FBaudRate:TBaudRate;
    FPort:string;
    FintPort:integer;
    FParity:TParityBits;
    FStopBits:TStopBits;
    FDataBits:TDataBits;
    FDTR,FRTS,FCTSFlowControl,FDSRFlowControl:Boolean;
    FOnOffOutFlowControl,FOnOffInFlowControl:Boolean;
    FOnRxChar: TRxCharEvent;
    FLastError:integer;
    FSleepTime:Cardinal;
    FUseThread:Boolean;
    F485SleepTime:Cardinal;
    FReadTotalTime:integer;
    FWriteTotalTime:integer;
    //FInternalReadTime: integer;
    FOnConnected: TNotifyEvent;
    Executeing:Boolean;
    function GetMode:Longint;
    procedure SetBaudRate(Value: TBaudRate);
    procedure SetPort(Value: string);
    procedure SetParity(Value: TParityBits);
    procedure SetStopBits(Value: TStopBits);
    procedure SetDataBits(Value: TDataBits);
    procedure SetDTR(Value: Boolean);
    procedure SetRTS(Value: Boolean);

    procedure SetCTSFlowControl(Value: Boolean);
    procedure SetDSRFlowControl(Value: Boolean);
    procedure SetOnOffOutFlowControl(Value: Boolean);
    procedure SetOnOffInFlowControl(Value: Boolean);
    function GetIqueue:integer;
    function GetOqueue:integer;
    function GetErrorMsg:string;
    procedure SetReadTotalTimeouts(Value:integer);
    procedure SetWriteTotalTimeouts(Value:integer);
    procedure SetUseThread(Value:Boolean);
    //procedure SetInternalReadTime(const Value: integer);
    function FindComPort(ComPort:TPort):integer;
    procedure AddComPort(ComPort:TPort);
    procedure DeleteComPort(ComPort:TPort);overload;
    procedure DeleteComPort(Index:integer);overload;
    function InMainThread:Boolean;
  protected
    { Protected declarations }
  public
    ExitWait:Boolean;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function GetBaudRate(BaudRate:integer):TBaudRate;
    function Open:Boolean;
    function Close:Boolean;
    //往端口写数据，如果返回值>=0，表示实际写入的数据长度，否则表示出错。
    function Write(Buffer:PChar; Count: integer): integer; overload;
    function Write(Buffer:array of Char; Count: integer): integer; overload;
    function Write(Buffer:array of Byte; Count: integer): integer; overload;
    function WriteString(Str: string): integer;

    function Write485(Buffer:PChar; Count: integer): integer; overload;
    function Write485(Buffer:array of Char; Count: integer): integer; overload;
    function Write485(Buffer:array of Byte; Count: integer): integer; overload;
    function WriteString485(Str: string): integer;
    //从端口读数据，如果返回值>=0，表示读出的数据长度，否则表示出错。
    function Read(Buffer:PChar; Count: integer): integer;overload;
    function Read(var Buffer:array of Char; Count: integer): integer;overload;
    function Read(var Buffer:array of Byte; Count: integer): integer;overload;
    function ReadString(var Str: string; Count: integer): integer;
    procedure Flush(func:TFlushBuffer);
    {
    func =
    0 :清除输入缓冲区
    1 :清除输出缓冲区
    2 :清除输入/输出缓冲区
    }
    procedure AbortWrite;
    procedure AbortRead;
    //最后的错误代码
    property LastError:integer read FLastError;
    //目前端口输入缓冲区中的数据长度
    property Iqueue:integer read GetIqueue;
    //目前端口输出缓冲区中的数据长度
    property Oqueue:integer read GetOqueue;
    property ErrorMsg:string read GetErrorMsg;
    property Connected:Boolean read FPortOpened;
  published
    //设定读超时时间
    //-1,立即返回
    //0，等待直到收到指定数目的数据
    //大于0，等待直到收到指定数目的数据或超时
    property ReadTotalTimeouts:integer read FReadTotalTime write SetReadTotalTimeouts default -1;
    //property InternalReadTime:integer read FInternalReadTime write SetInternalReadTime default 0;
    //设定写超时时间
    //-1,立即返回
    //0，等待直到发出所有数据
    //大于0，等待直到发出所有数据，如果该时间内未发出，则返回
    property WriteTotalTimeouts:integer read FWriteTotalTime write SetWriteTotalTimeouts default 0;
    property OnReceiveData: TRxCharEvent read FOnRxChar write FOnRxChar;
    property BaudRate: TBaudRate read FBaudRate write SetBaudRate;
    property Port: string read FPort write SetPort;
    property Parity: TParityBits read FParity write SetParity;
    property StopBits: TStopBits read FStopBits write SetStopBits;
    property DataBits: TDataBits read FDataBits write SetDataBits;
    property UseThread:Boolean read FUseThread write SetUseThread default True;
    property ThreadSleepTime:Cardinal Read FSleepTime write FSleepTime default 2;
    property SleepTimeOf485:Cardinal read F485SleepTime write F485SleepTime default 20;
    property DTR:Boolean read FDTR write SetDTR default True;
    property RTS:Boolean read FRTS write SetRTS default True;
    property CTSFlowControl:Boolean read FCTSFlowControl write SetCTSFlowControl default False;
    property DSRFlowControl:Boolean read FDSRFlowControl write SetDSRFlowControl default False;
    property OnOffOutFlowControl:Boolean read FOnOffOutFlowControl write SetOnOffOutFlowControl default False;
    property OnOffInFlowControl:Boolean read FOnOffInFlowControl write SetOnOffInFlowControl default False;
    property OnConnected:TNotifyEvent read FOnConnected write FOnConnected;
  end;

procedure Register;
procedure SetMonitorComPortsPerThread(Value:Word);

implementation
                                  
var
  ThreadList:TList;
  ComPortList:TList;
  ThreadCount:integer;
  MonitorComPortsPerThread:Word=15;
  ComPortCritical:TRTLCriticalSection;
  ProcDestroying:Boolean=False;
procedure Register;
begin
  RegisterComponents('AnyLib', [TPort]);
end;

type

  TPortThread = class(TThread)
  private
    Index:integer;
  protected
    procedure Execute; override;
  public
    constructor Create(Index:integer);
    destructor Destroy; override;
  end;

procedure UpdateThreadNumbers;
var
  Count,i:integer;
begin
  if MonitorComPortsPerThread=0 then Exit;
  try
    Count:=ComPortList.Count div MonitorComPortsPerThread;
    if (ComPortList.Count mod MonitorComPortsPerThread)<>0 then
      Inc(Count);
    if Count>ThreadCount then
    begin
      for i:=ThreadCount to Count-1 do
        TPortThread.Create(i);
    end
    else if Count<ThreadCount then
    begin
      for i:=ThreadCount-1 downto Count do
      begin
        TThread(ThreadList.Items[i]).Terminate;
        ThreadList.Delete(i);
      end;
    end;
  except
  end;
end;

procedure SetMonitorComPortsPerThread(Value:Word);
begin
  if Value<=0 then Exit;
  MonitorComPortsPerThread:=Value;
  UpdateThreadNumbers;
end;

{ TPort }

procedure TPort.AbortRead;
begin
  FLastError:=sio_AbortRead(FintPort);
end;

procedure TPort.AbortWrite;
begin
  FLastError:=sio_AbortWrite(FintPort);
end;

function TPort.Close: Boolean;
begin
  if not FPortOpened then
  begin
    Result:=False;
    FLastError:=SIO_BADPORT;
    Exit;
  end;
  sio_flush(FintPort,2);
  FLastError:=sio_close(FintPort);
  Result:=FLastError=SIO_OK;
  if Result then
    FPortOpened:=False;
end;

constructor TPort.Create(AOwner: TComponent);
begin
  inherited;
  Executeing:=False;
  FPort:='COM1';
  FintPort:=1;
  FSleepTime:=2;
  F485SleepTime:=20;
  FUseThread:=True;
  FBaudRate:=br9600;
  FDataBits:=dbEight;
  FParity:=prNone;
  FStopBits:=sbOneStopBit;
  FDTR:=True;
  FRTS:=True;
  FReadTotalTime:=-1;
  FWriteTotalTime:=0;
  //FInternalReadTime:=0;
  FCTSFlowControl:=False;
  FDSRFlowControl:=False;
  FOnOffOutFlowControl:=False;
  FOnOffInFlowControl:=False;
  AddComPort(Self);
end;

destructor TPort.Destroy;
begin
  DeleteComPort(Self);
  if FPortOpened then
    Close;
  inherited;
end;

procedure TPort.Flush(func:TFlushBuffer);
begin
  FLastError:=SIO_BADPORT;
  if not FPortOpened then
    Exit;
  FLastError:=sio_flush(FintPort,Ord(func));
end;

function TPort.GetIqueue: integer;
begin
  Result:=-1;
  FLastError:=SIO_BADPORT;
  if not FPortOpened then
    Exit;
  FLastError:=sio_iqueue(FintPort);
  if FLastError>=0 then
    Result:=FLastError
  else
    Result:=-1;
end;

function TPort.GetMode: Longint;
var
  byteDB,byteSB,bytePR:Byte;
begin
  byteDB:=0;
  byteSB:=0;
  bytePR:=0;
  case FDataBits of
    dbFive:byteDB:=0;
    dbSix:byteDB:=1;
    dbSeven:byteDB:=2;
    dbEight:byteDB:=3;
  end;
  case FStopBits of
    sbOneStopBit:byteSB:=0;
    sbTwoStopBits:byteSB:=4;
  end;
  case FParity of
    prNone:bytePR:=0;
    prOdd:bytePR:=8;
    prEven:bytePR:=$18;
    prMark:bytePR:=$28;
    prSpace:bytePR:=$38;
  end;
  Result:=byteDB or byteSB or bytePR;
end;

function TPort.GetOqueue: integer;
begin
  Result:=-1;
  FLastError:=SIO_BADPORT;
  if not FPortOpened then
    Exit;
  FLastError:=sio_oqueue(FintPort);
  if FLastError>=0 then
    Result:=FLastError
  else
    Result:=-1;
end;

function TPort.Open: Boolean;
begin
  if FPortOpened then
  begin
    Result:=True;
    FLastError:=SIO_OK;
    Exit;
  end;  
  Result:=False;
  FLastError:=sio_open(FintPort);
  if FLastError=SIO_OK then
  begin
    FPortOpened:=True;
    SetBaudRate(FBaudRate);
    SetParity(FParity);
    SetStopBits(FStopBits);
    SetDataBits(FDataBits);
    SetWriteTotalTimeouts(FWriteTotalTime);
    SetReadTotalTimeouts(FReadTotalTime); 
    SetDTR(FDTR);
    SetRTS(FRTS);       
    SetCTSFlowControl(FCTSFlowControl);
    SetDSRFlowControl(FDSRFlowControl);
    SetOnOffOutFlowControl(FOnOffOutFlowControl);
    SetOnOffInFlowControl(FOnOffInFlowControl);
    Result:=True;
    if Assigned(FOnConnected) then
      FOnConnected(Self);
  end;

end;

function TPort.Read(Buffer:PChar; Count: integer): integer;
var
  OldTime:Cardinal;
begin
  FLastError:=SIO_BADPORT;
  Result:=0;
  if not FPortOpened then
    Exit;
  if (FReadTotalTime>=0) then
  begin
    OldTime:=GetTickCount;
    while True do
    begin
      if Iqueue>=Count then Break;
      if FReadTotalTime>0 then
        if Abs(GetTickCount-OldTime)>=FReadTotalTime then
          Break;
      if ExitWait or ProcDestroying or (csDestroying in ComponentState) then
      begin
        ExitWait:=False;
        Break;
      end;
      if InMainThread then
      begin
        Sleep(2);
        Application.ProcessMessages;
      end
      else
        Sleep(5);
    end;
  end;
  FLastError:=sio_read(FintPort,Buffer,Count);
  if FLastError>=0 then
    Result:=FLastError;
end;

function TPort.ReadString(var Str: string; Count: integer): integer;
var
  Buffer:PChar;
  i:integer;
  OldTime:Cardinal;
begin
  FLastError:=SIO_BADPORT;
  Result:=0;
  str:='';
  if not FPortOpened then
    Exit;
  if (FReadTotalTime>=0) then
  begin
    OldTime:=GetTickCount;
    while True do
    begin
      if Iqueue>=Count then Break;
      if FReadTotalTime>0 then
        if Abs(GetTickCount-OldTime)>=FReadTotalTime then
          Break;
      if ExitWait or ProcDestroying or (csDestroying in ComponentState) then
      begin
       ExitWait:=False;
       Break;
      end;
      if InMainThread then
      begin
        Sleep(2);
        Application.ProcessMessages;
      end
      else
        Sleep(5);
    end;
  end;
  GetMem(Buffer,Count);
  FLastError:=sio_read(FintPort,Buffer,Count);
  if FLastError>=0 then
  begin
    Result:=FLastError;
    SetLength(str,Result);
    for i:=1 to Result do
      str[i]:=Buffer[i-1];
  end;
  FreeMem(Buffer,Count);
end;

procedure TPort.SetBaudRate(Value: TBaudRate);
var
  intBaudRate:integer;
  index:integer;
begin
  FLastError:=SIO_BADPORT;
  FBaudRate:=Value;
  if not FPortOpened then
    Exit;
  index:=Ord(Value);
  intBaudRate:=BaudRateconst[index];
  FLastError:=sio_baud(FintPort,intBaudRate);
end;

procedure TPort.SetCTSFlowControl(Value: Boolean);
var
  ret:integer;
begin
  FLastError:=SIO_BADPORT;
  FCTSFlowControl:=Value;
  if not FPortOpened then
    Exit;
  ret:=sio_getflow(FintPort);
  FLastError:=ret;
  if ret>=0 then
  begin
    if Value then
      ret:=ret or $1
    else
      ret:=ret and $FFFE;
    FLastError:=sio_flowctrl(FintPort,ret);
  end;
end;

procedure TPort.SetDataBits(Value: TDataBits);
begin
  FLastError:=SIO_BADPORT;
  FDataBits:=Value;
  if not FPortOpened then
    Exit;
  FLastError:=sio_ioctl(FintPort,Ord(FBaudRate),GetMode);
end;

procedure TPort.SetDTR(Value: Boolean);
begin
  FLastError:=SIO_BADPORT;
  FDTR:=Value;
  if not FPortOpened then
    Exit;
  if Value then
    FLastError:=sio_DTR(FintPort,1)
  else
    FLastError:=sio_DTR(FintPort,0);
end;

procedure TPort.SetParity(Value: TParityBits);
begin
  FLastError:=SIO_BADPORT;
  FParity:=Value;
  if not FPortOpened then
    Exit;
  FLastError:=sio_ioctl(FintPort,Ord(FBaudRate),GetMode);
end;