port.pas

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

procedure TPort.SetPort(Value: string);
begin
  FPort:=Value;
  if CompareText('Com',Copy(Value,1,3))=0 then
    FintPort:=StrToInt(Copy(FPort,4,Length(FPort)))
  else
    FintPort:=StrToInt(Value);
end;

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

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

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

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

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

function TPort.Write(Buffer:PChar; Count: integer): integer;
begin
  FLastError:=SIO_BADPORT;
  Result:=0;
  if not FPortOpened then
    Exit;
  FLastError:=sio_write(FintPort,Buffer,Count);
  if FLastError>=0 then
    Result:=FLastError;
end;

function TPort.WriteString(Str: string): integer;
var
  Buffer:PChar;
begin
  FLastError:=SIO_BADPORT;
  Result:=0;
  if not FPortOpened then
    Exit;
  Buffer:=PChar(Str);
  FLastError:=sio_write(FintPort,Buffer,Length(str));
  if FLastError>=0 then
    Result:=FLastError;
end;
                             
{ TComThread }

constructor TPortThread.Create(Index:integer);
begin
  Inc(ThreadCount);
  ThreadList.Add(Self);
  Self.Index:=Index;
  FreeOnTerminate:=True;
  inherited Create(False);
end;

destructor TPortThread.Destroy;
begin
  Dec(ThreadCount);
  inherited;
end;

procedure TPortThread.Execute;
var
  RecieveLen:integer;
  i:integer;
  APort:TPort;
begin
  APort:=nil;
  while not Terminated and not ProcDestroying do
  begin
    try
      for i:=Index*MonitorComPortsPerThread to Index*MonitorComPortsPerThread+MonitorComPortsPerThread-1 do
      begin
        if Terminated or ProcDestroying then Exit;
        EnterCriticalSection(ComPortCritical);
        try
          if (i<0) or (i>ComPortList.Count-1) then Continue;
          APort:=ComPortList.Items[i];
        finally
          LeaveCriticalSection(ComPortCritical);
        end;
        if (APort<>nil) and APort.FUseThread
          and not APort.Executeing
          and not (csDestroying in APort.ComponentState) then
        begin
          APort.Executeing:=True;
          try
            if not Terminated and APort.FPortOpened then
            begin
              RecieveLen:=sio_iqueue(APort.FintPort);
              if RecieveLen>0 then
              begin
                if not Terminated and Assigned(APort.OnReceiveData) then
                  try
                    APort.OnReceiveData(APort,RecieveLen);
                  except
                  end;
              end;
              if Terminated then Exit;
              if not (csDestroying in APort.ComponentState) then
                Sleep(APort.FSleepTime);
            end;
          finally
            try
              if not (csDestroying in APort.ComponentState) then
                APort.Executeing:=False;
            except
            end;    
          end;
        end;
      end;
      if Terminated then Exit;
      Sleep(5);
    except
    end;
  end;
end;

function TPort.GetErrorMsg: string;
begin
  Result:='';
  case FLastError of
    SIO_OK           :Result:='';
    SIO_BADPORT      :Result:='端口不存在或端口没打开';{ No such port or port not opened }
    SIO_OUTCONTROL   :Result:='不能控制板卡';  { Can't control board }
    SIO_NODATA       :Result:='没有可读写的数据';  { No data to read or no buffer to write }
    SIO_OPENFAIL     :Result:='端口不存在或端口已经被打开';   { No such port or port has opened }
    SIO_RTS_BY_HW    :Result:='不能设置,因为H/W流控制被设置为自动';  { Can't set because H/W flowctrl }
    SIO_BADPARM      :Result:='错误的参数';  { Bad parameter }
    SIO_WIN32FAIL    :Result:='调用win32函数失败,请调用GetLastError函数取得错误代码';  (* Call win32 function fail, please call }
                               GetLastError to get the error code *)
    SIO_BOARDNOTSUPPORT  :Result:='串口不支持该功能';  { Board does not support this function}
    SIO_FAIL         :Result:='PComm函数运行错误'; { PComm function run result fail }
    SIO_ABORT_WRITE  :Result:='写已经锁定,且被用户终止了'; { Write has blocked, and user abort write }
    SIO_WRITETIMEOUT :Result:='写超时'; { Write timeout has happened }
  end;
end;

function TPort.Read(var Buffer: array of Byte; Count: integer): integer;
begin
  Result:=Read(@Buffer[0],Count);
end;

function TPort.Read(var Buffer: array of Char; Count: integer): integer;
begin
  Result:=Read(@Buffer[0],Count);
end;

function TPort.Write(Buffer: array of Byte; Count: integer): integer;
begin
  Result:=Write(@Buffer,Count);
end;

function TPort.Write(Buffer: array of Char; Count: integer): integer;
begin
  Result:=Write(@Buffer,Count);
end;
{
function TPort.GetReadTotalTimeouts: integer;
var
  Total,Interval:Cardinal;
begin
//-1,立即返回
//0，等待直到收到指定数目的数据
//大于0，等待直到该时间过时
  FLastError:=SIO_BADPORT;
  Result:=-1;
  if FPortOpened then
  begin
    FLastError:=sio_GetReadTimeouts(FintPort,Total,Interval);
    if FLastError=SIO_OK then
    begin
      if Total=MAXDWORD then
        Result:=-1
      else Result:=Interval;
    end;
  end;
  FReadTotalTime:=Result;
end;

function TPort.GetWriteTotalTimeouts: integer;
var
  Total:Cardinal;
begin
//-1,立即返回
//0，等待直到发出所有数据
//大于0，等待直到发出所有数据，如果该时间内未发出，则返回
  FLastError:=SIO_BADPORT;
  Result:=0;
  if FPortOpened then
  begin
    FLastError:=sio_GetWriteTimeouts(FintPort,Total);
    if FLastError=SIO_OK then
    begin
      if Total=MAXDWORD then
        Result:=-1
      else
        Result:=Total;
    end;
  end;
  FWriteTotalTime:=Result;
end;
}
procedure TPort.SetReadTotalTimeouts(Value: integer);
begin
  FLastError:=SIO_BADPORT;
  FReadTotalTime:=Value;
  if FPortOpened then
  begin
    {if not FUseThread then
    begin
      if Value<=-1 then
        FLastError:=sio_SetReadTimeouts(FintPort,MAXDWORD,0)
      else
        FLastError:=sio_SetReadTimeouts(FintPort,Value,0);
    end
    else
    begin }
      FLastError:=SIO_OK;
    //end;
  end;
end;

procedure TPort.SetWriteTotalTimeouts(Value: integer);
begin
  FLastError:=SIO_BADPORT;
  FWriteTotalTime:=Value;
  if FPortOpened then
  begin
    if Value<=-1 then
      FLastError:=sio_SetWriteTimeouts(FintPort,MAXDWORD)
    else
      FLastError:=sio_SetWriteTimeouts(FintPort,Value);
  end;
end;

procedure TPort.SetUseThread(Value: Boolean);
var
  Index:integer;
begin
  if FUseThread<>Value then
  begin
    FUseThread:=Value;
    Index:=FindComPort(Self);
    if Value then
    begin
      if Index=-1 then
        AddComPort(Self);
    end
    else if Index<>-1 then
    begin
      DeleteComPort(Index);
    end;
  end;
end;

function TPort.Write485(Buffer: array of Char; Count: integer): integer;
begin
  Result:=Write485(@Buffer,Count);
end;

function TPort.Write485(Buffer: PChar; Count: integer): integer;
begin
  FLastError:=SIO_BADPORT;
  Result:=0;
  if not FPortOpened then
    Exit;
  FLastError:=sio_putb_x_ex(FintPort,Buffer,Count,F485SleepTime);
  if FLastError>=0 then
    Result:=FLastError;  
end;

function TPort.Write485(Buffer: array of Byte; Count: integer): integer;
begin
  Result:=Write485(@Buffer,Count);
end;

function TPort.WriteString485(Str: string): integer;
var
  Buffer:PChar;
begin
  FLastError:=SIO_BADPORT;
  Result:=0;
  if not FPortOpened then
    Exit;
  Buffer:=PChar(Str);
  FLastError:=sio_putb_x_ex(FintPort,Buffer,Length(str),F485SleepTime);
  if FLastError>=0 then
    Result:=FLastError;
end;
{
function TPort.GetCTSFlowControl: Boolean;
var
  ret:integer;
begin
  FLastError:=SIO_BADPORT;
  Result:=False;
  if not FPortOpened then
    Exit;
  ret:=sio_getflow(FintPort);
  FLastError:=ret;
  if ret>=0 then
    Result:=(ret and $01)>0;
  FCTSFlowControl:=Result;
end;

function TPort.GetDSRFlowControl: Boolean;
var
  ret:integer;
begin
  FLastError:=SIO_BADPORT;
  Result:=False;
  if not FPortOpened then
    Exit;
  ret:=sio_getflow(FintPort);
  FLastError:=ret;
  if ret>=0 then
    Result:=(ret and $02)>0;
 FDSRFlowControl:=Result;
end;

function TPort.GetOnOffInFlowControl: Boolean;
var
  ret:integer;
begin
  FLastError:=SIO_BADPORT;
  Result:=False;
  if not FPortOpened then
    Exit;
  ret:=sio_getflow(FintPort);
  FLastError:=ret;
  if ret>=0 then
    Result:=(ret and $08)>0;
  FOnOffInFlowControl:=Result;  
end;

function TPort.GetOnOffOutFlowControl: Boolean;
var
  ret:integer;
begin
  FLastError:=SIO_BADPORT;
  Result:=False;
  if not FPortOpened then
    Exit;
  ret:=sio_getflow(FintPort);
  FLastError:=ret;
  if ret>=0 then
    Result:=(ret and $04)>0;
 FOnOffOutFlowControl:=Result;
end;

procedure TPort.SetInternalReadTime(const Value: integer);
begin
  FLastError:=SIO_BADPORT;
  FInternalReadTime:=Value;
  if FPortOpened then
  begin
    if FReadTotalTime<=-1 then
      FLastError:=sio_SetReadTimeouts(FintPort,MAXDWORD,Value)
    else
      FLastError:=sio_SetReadTimeouts(FintPort,FReadTotalTime,Value);
  end;
end;                           
}
function TPort.GetBaudRate(BaudRate: integer): TBaudRate;
var
  i:integer;
begin
  for i:=0 to High(BaudRateConst) do
    if BaudRateConst[i]=BaudRate then
    begin
      Result:=TBaudRate(i);
      Exit;
    end;
  Result:=br9600;
end;

procedure TPort.AddComPort(ComPort: TPort);
begin
  EnterCriticalSection(ComPortCritical);
  try
    ComPortList.Add(ComPort);
  finally
    LeaveCriticalSection(ComPortCritical);
  end;
  UpdateThreadNumbers;
end;

procedure TPort.DeleteComPort(ComPort: TPort);
var
  Index:integer;
begin
  Index:=FindComPort(ComPort);
  if Index=-1 then Exit;
  try
    EnterCriticalSection(ComPortCritical);
    try
      ComPortList.Delete(Index);
    finally
      LeaveCriticalSection(ComPortCritical);
    end;
  except
  end;
  UpdateThreadNumbers;
end;

function TPort.FindComPort(ComPort: TPort): integer;
begin
  Result:=ComPortList.IndexOf(ComPort);
end;

procedure TPort.DeleteComPort(Index: integer);
begin
  if Index=-1 then Exit;
  try
    EnterCriticalSection(ComPortCritical);
    try
      ComPortList.Delete(Index);
    finally
      LeaveCriticalSection(ComPortCritical);
    end;
  except
  end;
  UpdateThreadNumbers;
end;

function TPort.InMainThread: Boolean;
begin
  Result:=GetCurrentThreadId=GetWindowThreadProcessId(Application.Handle);
end;

function TerminateProc:Boolean;
begin
  ProcDestroying:=True;
  Result:=True;
end;

initialization
  AddTerminateProc(TerminateProc);
  ThreadList:=TList.Create;
  ComPortList:=TList.Create;
  InitializeCriticalSection(ComPortCritical);
finalization
  ProcDestroying:=True;
  ThreadList.Free;
  ComPortList.Free;
  DeleteCriticalSection(ComPortCritical);
end.