求一个API函数写串口的源代码

你去下载SPCOMM组件，那个就是你要的东西，看它的源码

你下个SPCOMM控件即可，它也是调用API的。有了它你不用再去考虑捕捉错误信息等。

unit EzCommPorts;
{ 高效简易的串行口对象单元 V2.1
作者: 吕树人 2013.8.20
应用:
const
  CM_COMMS = WM_USER + ??; // 定义串行口通知消息号(串行口异步协调通过向指定窗口PostMessage实现)
type
  TMainForm = class(TForm)
  private
    procedure DoCmComms(var M: TMessage); message CM_COMMS; // 串行口消息声明
  end;定义自己的串行口(对接收数据的处理)
type
  TMyComm = class(TCommPortz)
  protected
    procedure RxData(nSize: Integer; var Data: TByteArray); override;
    procedure TxData(TxFrmId: Integer; pData: PTxFrmBuf; TxFailed: Boolean); override;
    procedure LineChanged(LineMask: DWORD); override; // CTS=$10/DSR=$20/RING=$40/DCD=$80 电平变化,x[0/1/2]:新/旧/XOR
    procedure BreakSignal; override; // 接收到一个BREAK信令(RX线在逻辑0状态保持100ms)
    procedure ErrorHandle(ErrCode: Integer); override;
  end;procedure TMainForm.CreateForm(Sender: TObject);
begin
  TCommPortz.Initialize(Handle, CM_COMMS);   // 初始化: 设定消息窗口(为主窗口)和消息号
  MyComm:= TMyComm.Create(Ini.ReadInt(...)); // 快速初始化串行口参数
  with MyComm do begin // 逐项配置参数
    PortNo:= 8;
    Baud:= 1200;
    EnableRx:= True;
    UseTxQue:= True;
    TxBuffSize:= 8192;
  end;
  MyComm.Open;
  if MyComm.Connected then Caption:= 'OK';
end;procedure TMainForm.DoCmComms(var M: TMessage);
begin // 串行口消息转回类方法进行解释
  TCommPortz.HandleMessage(M.WParam, M.LParam);
end;
}
interfaceuses
  Windows, Messages, SysUtils, Classes;type
  TCommTxFrmBuf = packed record
    Size: DWORD;
    Data: array [0..255] of Byte;
  end;
  PCommTxFrmBuf = ^TCommTxFrmBuf;  TCommPortz = class(TObject)
  private
    F: packed record case Boolean of
      False:(AsInt: Integer);
      True:(
       BaudEx: Byte;  // [D3..D0]: 波特率索引; D4($10):CTS; D5($20):DSR; D6($40):RING; D7($80):DCD(RLSD)
       TxSize: Byte;  // [D3..D0]: 发送队列大小(256字节对齐,最大4K);
                      // [D4..D7]: 设置位: D12($10):EnableRx; D13($20):UseTxQue; D14($40):DTR; D15($80):RTS
       PortNo: Byte;  // COM? 串口号(COM1..COM255)
       nIndex: Byte); // 内部序号(GetSettings提取时不包括此域)
    end;
    FCommFile : THandle; // 串行口文件
    FStopEvent: THandle; // 线程停止事件
    FWantClose: Boolean; // 通知线程退出的标志(为提高安全性)
    FThd: array [0..1] of TThread; // [0写/1读]线程
    FTxOvl: TOverlapped;           // 写端口的重叠结构

    function  GetBaud: Integer;
    procedure SetBaud(Value: Integer);
    function  GetTxQueSize: Integer;
    procedure SetTxQueSize(Value: Integer);
    procedure SetPortNo(Value: Byte);    function  GetBits(Index: Integer): Boolean;        // 提取F域的标志量
    procedure SetBits(Index: Integer; Value: Boolean); // 必须在关闭状态下设置标志量
    procedure SetLineLevel(Index: Integer; Value: Boolean);
    function  GetLineLevel(Index: Integer): Boolean;    // 按DB9插座线号取电平
  protected
    function Openned: Boolean; // 串行口文件已打开(FCommFile, FStopEvent, FThd, FTxOvl 成员有效)
    function zThreadsFinished: Boolean; // 读写线程都已停止    // 由子类实现的处理:
    procedure RxData(nSize: Integer; var vRxData: TByteArray); virtual;
    procedure TxData(TxFrmId: Integer; pData: PCommTxFrmBuf; TxFailed: Boolean); virtual;
    procedure LineChanged(LineMask: DWORD); virtual; // CTS=$10/DSR=$20/RING=$40/DCD=$80 电平变化,x[0/1/2]:新/旧/XOR
    procedure BreakSignal; virtual; // 接收到一个BREAK信令(RX线在逻辑0状态保持超过一字节时间)
    procedure ErrorHandle(ErrCode: Integer); virtual;
  public
    // 初始化并设定消息窗口
    class procedure Initialize(nWnd: HWND; nMsg, nRxBuffSize: WORD);
    class function  Ports(Index: Integer): TCommPortz;      // 根据内部序号取串行口
    class procedure HandleMessage(WPARAM, LPARAM: Integer); // 消息处理入口(外部窗口中转消息到这里)    constructor Create(nSettings: Integer); virtual;
    destructor Destroy; override;    function GetTxBuff(nSize: Integer): PCommTxFrmBuf; // 取一个发送缓冲区(在 UseTxQue 前提下)
    function SendData(pData: PCommTxFrmBuf): Integer;  // 发送数据(返回帧流水号)
    function Connected: Boolean; // 串行口已连接(Openned and not WantClose)
    function TxEmpty: Boolean;   // 发送空闲状态
    procedure Open; virtual;
    procedure Close; virtual;    property PortIndex: Byte read F.nIndex; // 内部序号
    property PortNo: Byte read F.PortNo write SetPortNo; // 串行口号 COM?
    property Baud: Integer read GetBaud write SetBaud;   // 波特率
    property TxQueSize: Integer read GetTxQueSize write SetTxQueSize; // 发送队列大小(256..4096)
    function GetIntSettings: Integer; // 快速保存参数    property EnableRx: Boolean index $1000 read GetBits write SetBits; // 允许读线程, 可接收数据和捕获口线电平变化
    property UseTxQue: Boolean index $2000 read GetBits write SetBits; // 允许写线程, 可以队列方式推送多帧数据    property CTSLevel : Boolean index $10 read GetBits; //  CTS(8) 线电平
    property DSRLevel : Boolean index $20 read GetBits; //  DSR(6) 线电平
    property RingLevel: Boolean index $40 read GetBits; // RING(9) 线电平
    property DCDLevel : Boolean index $80 read GetBits; //  DCD(1) 线电平    property DTRLevel: Boolean index 4 read GetLineLevel write SetLineLevel; // DTR(4)线电平
    property RTSLevel: Boolean index 7 read GetLineLevel write SetLineLevel; // RTS(7)线电平
    property Levels[Index: Integer]: Boolean read GetLineLevel write SetLineLevel; // 按DB9插座线号取电平
  end;implementationtype
  // 环型缓冲区结构
  TRingBuff = record
    nPtr  : Integer; // 当前分配指针
    nDataZ: Integer; // 尾边界(计算折回)
    case Boolean of
      False:(pBuff: Pointer); // 指向缓冲区内存
      True :(nBuff: Integer);
  end;  // 读写线程(写线程重载Execute,InitParams!)
  TRxThd = class(TThread)
  private
    FOwner: TCommPortz;
    FFinished: Boolean; // 线程已执行结束标志(用于关闭串行口时释放)
  protected
    procedure Execute; override;
    procedure InitParams; virtual;
  public
    constructor Create(AOwner: TCommPortz);
    destructor Destroy; override;
  end;  TTxThd = class(TRxThd) // 写线程
  private
    FRunSignal: THandle;   // 启动发送信号量
    FBuff: TRingBuff;      // 发送队列
    Que: packed record
     vIn, vOut: Byte;  // 队列指针
     Idle: WordBool;   // 无发送, 线程空闲
    end;
    FTxQue: array [0..255] of Pointer;
    procedure AddTxData(pData: PCommTxFrmBuf);
  protected
    procedure Execute; override;
    procedure InitParams; override;
  end;  // 消息的 WPARAM 结构
  TMsgWParam = packed record case Boolean of
    False:(
      DataLen  : WORD;  // 接收数据块长度
      PortIndex: Byte;  // 本消息的串行口对象内部序号
      bMsg     : Byte); // 消息号    True:( // 发送消息定义:
      IsFrmId: ByteBool;  // 不可释放缓冲区, LPARAM为FrmId
      TxError: ByteBool); // 发送过程出错
  end;const
  // 消息常数 TMsgWParam.bMsg
  cvmTxData = $0; // 发送完成(低半字节中为状态: 0:正常不需释放数据,1:正常但需要释放数据...)
  cvmRxData = $1; // 接收到数据(LParam -> 数据块)
  cvmLevels = $2; // 口线有变化(CTS,DSR,RING)
  cvmBreak  = $3; // BREAK 信令
  cvmError  = $4; // 有错误
  cvmError1 = $5; // 错误: 发送过程 WriteFile 调用错  // DCB 常数
  dcb_Binary     = $00000001;
  dcb_DtrControl = $00000030;
  dcb_RtsControl = $00003000;  // 监视线程需要捕获的事件：
  cEventMasks: DWORD = EV_CTS or EV_DSR or EV_ERR or EV_RING or EV_RXCHAR or EV_RLSD or EV_BREAK;
  cCommErrors: DWORD = CE_FRAME or CE_MODE or CE_OVERRUN or CE_RXOVER or CE_RXPARITY or CE_TXFULL;  // 波特率定义：
  BaudConsts: array [0..15] of Integer =
    (0, 600, 1200, 2400, 4800, 9600, 14400, 19200, 28800, 33600, 38400, 57600, 115200, 0, 0, 0);
  // 0  1    2     3     4     5     6      7      8      9      10     11     12      13 14 15  // 各速率下的一级缓冲区设置：
  cRxBuffSize: array [1..12] of WORD = (
        32, 32, { 600, 1200 250ms}
        64, 64, {2400, 4800 133ms}
       128,     {9600   133ms}
       256,     {14400  177ms}
       256,     {19200  133ms}
       512,     {28800  133ms}
      1024, 1024, 1024, 1024); {33600, 38400, 57600, 115200}
var
  FMsgWnd: HWND = 0;     // 中转消息的窗口(通常是应用程序主窗口)
  FMsgNum: Integer = 0;  // 消息号
  FTxFrmId: Integer = 0; // 全局发送帧的帧序号(自动累加)  FList: TList; // 串行口对象集合
  FRxBuff: TRingBuff; // 全局的接收缓存(读取数据至缓冲区后提交指针给主线程)
  FCritical: TRTLCriticalSection; // 分配全局接收缓存时保证线程安全// 内部过程// 初始化一个环形缓冲区
procedure zInitDataBuf(var aBuff: TRingBuff; BuffSize: Integer);
begin
  with aBuff do begin
    pBuff:= nil;
    if BuffSize <> 0 then begin
      GetMem(pBuff, BuffSize);
      nPtr:= nBuff;
      nDataZ:= nBuff + BuffSize;
    end;
  end;
end;// 从环形缓冲区分配(必须高效, 调用者检查安全)
function zGetDataBuff(nSize: Integer; var aBuff: TRingBuff): Pointer;
var
  nResult: Integer absolute Result;
  X, Size1: Integer;
begin
  Size1:= (nSize + 3) and $FFC; // 分配内存地址4字节对齐
  with aBuff do begin
    X:= nPtr + Size1;
    if X < nDataZ then begin
      nResult:= nPtr;
      nPtr:= X;
    end else begin
      Result:= pBuff;
      nPtr:= nBuff + Size1;
    end;
  end;
end;// 分配全局的接收缓冲区
function zGetRxDataBuff(nSize: Integer): Pointer;
begin
  EnterCriticalSection(FCritical); // 可能同时多个串行口接收, 必须保证线程安全
  Result:= zGetDataBuff(nSize, FRxBuff);
  LeaveCriticalSection(FCritical);
end;// 本单元初始化
class procedure TCommPortz.Initialize(nWnd: HWND; nMsg, nRxBuffSize: WORD);
var
  bSize: array [0..1] of Byte absolute nRxBuffSize;
begin
  if Assigned(FList) then
    raise Exception.Create('TCommPortz.Initialize again!') // 不可重复初始化
  else if IsWindow(nWnd) and (nMsg >= WM_USER) then begin
    FList:= TList.Create;
    FMsgWnd:= nWnd;
    FMsgNum:= nMsg;
    if (nRxBuffSize = 0) or (bSize[0] <> 0) then begin
      bSize[0]:= 0; Inc(bSize[1]);
    end;
    zInitDataBuf(FRxBuff, nRxBuffSize);   // 初始化全局接收缓存
    InitializeCriticalSection(FCritical); // 初始化接收缓存线程安全临界区对象
  end else begin
    raise Exception.Create('TCommPortz.Initialize: Invalid Parameters!');
  end;
end;class function TCommPortz.Ports(Index: Integer): TCommPortz;
begin
  Result:= nil;
  if (Index >= 0) and (Index < FList.Count) then Result:= FList[Index];
end;

class procedure TCommPortz.HandleMessage(WPARAM, LPARAM: Integer);
var
  W : TMsgWParam absolute WPARAM;
  Pw: PWORDARRAY absolute LPARAM;
  Px: PByteArray absolute LPARAM;
  V: TCommPortz;
  zTxFrmId: Integer;
begin
  V:= Ports(W.PortIndex);
  if Assigned(V) then if V.Connected then case W.bMsg of
    cvmTxData: begin // 发送数据
      if W.IsFrmId then
        V.TxData(LParam, nil, W.TxError) // 发送缓冲区不可释放,不送出指针,只送帧序号
      else begin
        zTxFrmId:= Pw^[1]; Pw^[1]:= 0; // 提取帧序号, 还原Size域
        V.TxData(zTxFrmId, Pointer(LPARAM), W.TxError);
      end;
    end;
    cvmRxData: V.RxData(W.DataLen, Px^); // 接收数据
    cvmLevels: V.LineChanged(LPARAM);    // 口线变动
    cvmBreak : V.BreakSignal;            // BREAK 同步
    cvmError : V.ErrorHandle(LParam);    // 错误处理
  end;
end;constructor TCommPortz.Create(nSettings: Integer);
begin
  if Assigned(FList) then begin
    FCommFile:= INVALID_HANDLE_VALUE;
    F.AsInt:= nSettings;
    FThd[0]:= nil;
    FThd[1]:= nil;
    FWantClose:= False;
    F.nIndex:= FList.Add(Self);
  end else begin
    raise Exception.Create('TCommPortz: Create without Initialize!');
  end;
end;destructor TCommPortz.Destroy;
begin
  Close;
  FList[F.nIndex]:= nil;
  inherited;
end;function TCommPortz.Openned: Boolean;
begin
  Result:= (FCommFile <> INVALID_HANDLE_VALUE);
end;function TCommPortz.Connected: Boolean;
begin
  Result:= Openned and (not FWantClose);
end;function TCommPortz.zThreadsFinished: Boolean;
var
  I: Integer;
begin
  Result:= True;
  for I:= 0 to 1 do if Assigned(FThd[I]) then Result:= Result and TRxThd(FThd[I]).FFinished;
end;function TCommPortz.GetTxBuff(nSize: Integer): PCommTxFrmBuf;
begin
  Result:= nil;
  if (nSize >= 1) and Connected and Assigned(FThd[0]) then
  with TTxThd(FThd[0]) do if FBuff.pBuff <> nil then begin
    Result:= zGetDataBuff(nSize + 4, FBuff); // 须多4字节存放 Size
    Result^.Size:= nSize;
  end;
end;function TCommPortz.SendData(pData: PCommTxFrmBuf): Integer;
var
  wTxFrmId: WORD absolute FTxFrmId;
  Pw: PWORDARRAY absolute pData;
begin
  if Connected then begin
    Result:= InterlockedIncrement(FTxFrmId) and $FFFF;
    if Assigned(FThd[0]) then begin
      // 采用队列方式发送
      Pw^[1]:= Result; // 记录帧流水号
      TTxThd(FThd[0]).AddTxData(pData); // 委托到发送线程
      Exit;
    end else begin
      // 不采用队列方式, 直接发送
      WaitForSingleObject(FTxOvl.hEvent, 100); // 防止重叠
      ResetEvent(FTxOvl.hEvent);
      if WriteFile(FCommFile, pData^.Data, Pw^[0], pData^.Size, @FTxOvl) then Exit;
    end;
  end;
  Result:= -1;
end;function zOpenSucceed(aCommPort: TCommPortz): Boolean;
var
  hComm: THandle;
  idBaud: Integer;  X: packed record case Byte of
    0: (sFix: WORD;
        sCommName: String[7]);
    1: (DCB: TDCB);
    2: (Timeouts: TCommTimeouts);
    3: (RxBuffSize, TxBuffSize: Integer);
  end;begin with aCommPort do begin
  Result:= False;  // 过滤可能出错的条件
  with F do begin
    if PortNo = 0 then Exit;   // 端口不可为0
    idBaud:= BaudEx and $F;
    if idBaud = 0 then Exit;   // 波特率不可为0
    if idBaud >= 13 then Exit; // 非法波特率
  end;  // 尝试打开串行口文件：
  FillChar(X, 8, 0);
  X.sFix:= $4F43; // 'CO'M
  Str(F.PortNo, X.sCommName);
  X.sCommName[0]:= 'M';
  hComm:= CreateFile(@X, GENERIC_READ or GENERIC_WRITE,
                     0,   {not shared}
                     nil, {no security}
                     OPEN_EXISTING,
                     FILE_ATTRIBUTE_NORMAL or FILE_FLAG_OVERLAPPED,
                     0 {template} );
  if hComm = INVALID_HANDLE_VALUE then Exit; // 打开失败  try // 串行口已经打开，下面的代码需要保护
    if GetFileType(hComm) <> FILE_TYPE_CHAR then Exit;
    with X do begin
      RxBuffSize:= cRxBuffSize[idBaud]; // 根据波特率取得一级缓冲区长度
      TxBuffSize:= 256; // 发送缓冲区不少于 256 字节
      if TxBuffSize < RxBuffSize then TxBuffSize:= RxBuffSize;
      if not SetupComm(hComm, RxBuffSize, TxBuffSize) then Exit;
    end; //                   ~~~~~~~~~~  ~~~~~~~~~~└→ 驱动层缓冲区    // 清除缓冲区：
    PurgeComm(hComm, PURGE_TXABORT or PURGE_RXABORT or PURGE_TXCLEAR or PURGE_RXCLEAR);    // 设置DCB
    FillChar(X, SizeOf(TDCB), 0);
    with X.DCB do begin
      DCBlength:= SizeOf(TDCB);
      Flags    := DCB_BINARY;
      BaudRate := BaudConsts[idBaud];
      ByteSize := 8;
      if DTRLevel then begin
        // DTR 线初始化为 1
        Flags:= Flags or (dcb_DtrControl and (DTR_CONTROL_ENABLE shl 4));
      end;
      if RTSLevel then begin
        // RTS 线初始化为 1
        Flags:= Flags or (dcb_RtsControl and (RTS_CONTROL_ENABLE shl 12))
      end;
    end;
    if not SetCommState(hComm, X.DCB) then Exit; // 设置失败    // 设置串口超时参数：
    FillChar(X, SizeOf(TCommTimeouts), 0);
    if not GetCommTimeouts(hComm, X.Timeouts) then Exit;
    with X.Timeouts do begin
      ReadIntervalTimeout        := MAXDWORD;
      ReadTotalTimeoutMultiplier := 0;
      ReadTotalTimeoutConstant   := 0;
      WriteTotalTimeoutMultiplier:= 10; // 每字节时间不超过10ms
      WriteTotalTimeoutConstant  := 500;
    end;
    if not SetCommTimeouts(hComm, X.Timeouts) then Exit;    Result:= True;
  finally
    if Result then
      FCommFile:= hComm // 打开成功, 保存Handle
    else begin
      GetLastError;
      CloseHandle(hComm); // 失败, 关闭串行口
    end;
  end;
end end;procedure TCommPortz.Open;
var
{$IFDEF VER100}
  dwLevels: Integer;  // for D3
{$ELSE}
  dwLevels: Cardinal; // for D4+
{$ENDIF}
begin
  Close;
  FillChar(FTxOvl, SizeOf(TOverlapped), 0);
  if zOpenSucceed(Self) then begin
    // 已成功打开串行口
    FWantClose:= False;
    FStopEvent:= CreateEvent(nil, True, False, nil);
    FTxOvl.hEvent:= CreateEvent(nil, True, False, nil);
    if UseTxQue then TTxThd.Create(Self); // 使用队列发送, 创建发送线程
    if EnableRx then TRxThd.Create(Self); // 启用事件捕获, 创建监视线程
    if GetCommModemStatus(FCommFile, dwLevels) then begin
      // 读取信号线
      dwLevels:= dwLevels and $F0; // CTS=$10;DSR=$20;RING=$40;RLSD=$80
      with F do begin
        BaudEx:= BaudEx and $F;
        AsInt:= AsInt or dwLevels;
      end;
    end;
  end;
end;procedure TCommPortz.Close;
var
  I: Integer;
begin try
  if not FWantClose then begin // 全局退出时清除过程提前停止了线程
    FWantClose:= True;
    if Openned then SetEvent(FStopEvent);
    for I:= 19 downto 0 do begin // 限时2秒
      if zThreadsFinished then Break;
      Sleep(100);
    end;
  end;
  for I:= 0 to 1 do if Assigned(FThd[I]) then FThd[I].Free;
  if Openned then begin
    CloseHandle(FStopEvent);
    CloseHandle(FTxOvl.hEvent);
    CloseHandle(FCommFile);
  end;
finally
  FCommFile:= INVALID_HANDLE_VALUE;
  for I:= 0 to 1 do FThd[I]:= nil;
end end;function TCommPortz.TxEmpty: Boolean;
begin
  Result:= False;
  if Connected then begin
    if Assigned(FThd[0]) then
      Result:= TTxThd(FThd[0]).Que.Idle
    else begin
      Result:= (WaitForSingleObject(FTxOvl.hEvent, 0) = WAIT_OBJECT_0);
    end;
  end;
end;function TCommPortz.GetBaud: Integer;
begin
  Result:= BaudConsts[F.AsInt and $F];
end;procedure TCommPortz.SetBaud(Value: Integer);
begin
  if Openned then Exit; // 串行口已打开则不可设置波特率
  with F do begin
    BaudEx:= 12;
    repeat
      if Value = BaudConsts[BaudEx] then Exit;
      Dec(BaudEx);
    until BaudEx = 0;
  end;
end;function TCommPortz.GetTxQueSize: Integer;
begin
  Result:= F.AsInt and $F00;
  if Result <> 0 then Inc(Result, $100);
end;procedure TCommPortz.SetTxQueSize(Value: Integer);
var
  X: array [0..1] of Byte absolute Value;
begin
  if Openned or (Value < 0) then Exit;
  with F do if Value = 0 then
    TxSize:= TxSize and $F0
  else begin
    Dec(Value);
    if Value < $1000 then TxSize:= (TxSize and $F0) or X[1];
  end;
end;procedure TCommPortz.SetPortNo(Value: Byte);
begin
  if not Openned then F.PortNo:= Value;
end;function TCommPortz.GetIntSettings: Integer; // 快速保存参数
begin
  Result:= F.AsInt and $FFFFFF; // 去掉内部序号
end;
procedure zSetBits(Index: WORD; Value: Boolean; var xParam);
var
  W: WORD absolute xParam;
begin
  if Value then W:= W or Index else W:= W and (Index xor $FFFF);
end;function TCommPortz.GetBits(Index: Integer): Boolean;
begin
  Result:= (F.AsInt and Index) <> 0;
end;procedure TCommPortz.SetBits(Index: Integer; Value: Boolean);
begin
  if not Openned then zSetBits(Index, Value, F);
end;function TCommPortz.GetLineLevel(Index: Integer): Boolean; // 按DB9插座线号取电平
const
  cLineChgs: array [1..9] of WORD = ($0080, $00, $00, $4000, $00, $0020, $8000, $0010, $0040);
begin                             // 1-DCD  2-RX 3-TX 4-DTR  GND  6-DSR  7-RTS  8-CTS  9-RING
  Result:= False;
  if Index in [1..9] then Result:= GetBits(cLineChgs[Index]);
end;procedure TCommPortz.SetLineLevel(Index: Integer; Value: Boolean);
const
  cxDTR: array [Boolean] of DWORD = (CLRDTR, SETDTR);
  cxRTS: array [Boolean] of DWORD = (CLRRTS, SETRTS);
begin case Index of
  4: begin
    if Connected then if not EscapeCommFunction(FCommFile, cxDTR[Value]) then Exit;
    zSetBits($4000, Value, F);
  end;
  7: begin
    if Connected then if not EscapeCommFunction(FCommFile, cxRTS[Value]) then Exit;
    zSetBits($8000, Value, F);
  end;
end end;// 通知事件处理方法, 子类实现
procedure TCommPortz.RxData; begin end;
procedure TCommPortz.TxData; begin end;
procedure TCommPortz.LineChanged; begin end;
procedure TCommPortz.BreakSignal; begin end;
procedure TCommPortz.ErrorHandle; begin end;

{ TRxThd }constructor TRxThd.Create(AOwner: TCommPortz);
begin
  inherited Create(True);
  FOwner:= AOwner;
  FFinished:= False;
  InitParams;
  Resume;
end;procedure TRxThd.InitParams;
begin
  SetCommMask(FOwner.FCommFile, cEventMasks);
  FOwner.FThd[1]:= Self;
end;procedure TRxThd.Execute;
const
  fzLevelMasks: DWORD = EV_CTS or EV_DSR or EV_RING or EV_RLSD;
  fzErrorClear: DWORD = PURGE_RXABORT or PURGE_RXCLEAR;
var
  FEvMasks: DWORD;
  P: Pointer absolute FEvMasks;  MsgW: TMsgWParam;
  IntW: Integer absolute MsgW;
{$IFDEF VER100}
  zCode: Integer;  // for D3
{$ELSE}
  zCode: Cardinal; // for D4+
{$ENDIF}
  bLevels: array [0..3] of Byte absolute zCode;  zHandles: array[0..1] of THandle;
  FStat: TComStat;
  zOvl, RxOvl: TOverlapped;begin
  // 初始化部分
  MsgW.PortIndex:= FOwner.PortIndex;
  FillChar(RxOvl, SizeOf(TOverlapped), 0);
  RxOvl.hEvent:= CreateEvent(nil, True, False, nil);  FillChar(zOvl, SizeOf(TOverlapped), 0);
  zOvl.hEvent:= CreateEvent(nil, True, False, nil);
  zHandles[1]:= FOwner.FStopEvent;  try repeat
    zHandles[0]:= zOvl.hEvent;
    FillChar(FStat, SizeOf(TComStat), 0);
    WaitCommEvent(FOwner.FCommFile, FEvMasks, @zOvl);
    case WaitForMultipleObjects(2, @zHandles, False, INFINITE) of
      WAIT_OBJECT_0: if GetOverlappedResult(FOwner.FCommFile, zOvl, zCode, False) then begin
        ClearCommError(FOwner.FCommFile, zCode, @FStat);
        zCode:= zCode and cCommErrors; // 只捕获指定的错误类型
        if (FEvMasks and EV_BREAK) <> 0 then begin
          MsgW.bMsg:= cvmBREAK; // BREAK 同步信号: 复位接收设备, 通知主线程(接收帧同步)
          PostMessage(FMsgWnd, FMsgNum, IntW, FStat.cbInQue); // LPARAM 为当前设备缓冲区内数据字节数
          PurgeComm(FOwner.FCommFile, fzErrorClear);        end else if zCode <> 0 then begin
          MsgW.bMsg:= cvmError; // 错误通知
          PostMessage(FMsgWnd, FMsgNum, IntW, zCode);
          PurgeComm(FOwner.FCommFile, fzErrorClear);        end else begin
          if (FEvMasks and fzLevelMasks) <> 0 then
          if GetCommModemStatus(FOwner.FCommFile, zCode) then begin
            zCode:= zCode and $F0; // CTS:$10;DSR:$20;RI:$40;RLSD:$80
            with FOwner.F do begin
              bLevels[1]:= BaudEx;                    // 保留原来的状态
              BaudEx:= (BaudEx and $F) or bLevels[0]; // 更新信号线状态
              bLevels[2]:= bLevels[1] xor BaudEx;     // 变化的
            end;
            if bLevels[2] <> 0 then begin
              MsgW.bMsg:= cvmLevels; // 口线状态更新通知
              PostMessage(FMsgWnd, FMsgNum, IntW, zCode);
            end;
          end;//fzLevelMasks/GetCommModemStatus          if FStat.cbInQue <> 0 then begin
            Inc(FStat.cbInQue, 8); // 多分配8字节
            zHandles[0]:= RxOvl.hEvent; // 替换事件
            P:= zGetRxDataBuff(FStat.cbInQue); // 分配接收缓存
            FillChar(RxOvl, SizeOf(TOverlapped), 0); // 复位 RxOvl 结构
            RxOvl.hEvent:= zHandles[0];
            if ReadFile(FOwner.FCommFile, P^, FStat.cbInQue, zCode, @RxOvl) then
            case WaitForMultipleObjects(2, @zHandles, False, INFINITE) of
              WAIT_OBJECT_0: if GetOverlappedResult(FOwner.FCommFile, RxOvl, zCode, False) then
                if zCode <> 0 then begin
                  MsgW.bMsg:= cvmRxData; // 消息!
                  MsgW.DataLen:= zCode;  // 实际接收到的字节数
                  PostMessage(FMsgWnd, FMsgNum, IntW, FEvMasks); // 接收到数据(LPARAM为缓冲区指针)
                end;              WAIT_OBJECT_0+1: Exit; // 强制中止
              else begin
                // 理论上不发生的代码
                ClearCommError(FOwner.FCommFile, zCode, @FStat);
                PurgeComm(FOwner.FCommFile, fzErrorClear);
              end;
            end;//ReadFile/case WaitFor...
          end;//FStat.cbInQue<>0        end;
      end;//WAIT_OBJECT_0(zOvl.hEvent)      WAIT_OBJECT_0+1: Exit; // 强制中止      else begin
        // 理论上不发生的代码
        ClearCommError(FOwner.FCommFile, zCode, @FStat);
        PurgeComm(FOwner.FCommFile, fzErrorClear);
      end;
    end;//case
  until FOwner.FWantClose;
  finally
    ClearCommError(FOwner.FCommFile, zCode, @FStat);
    PurgeComm(FOwner.FCommFile, fzErrorClear);
    CloseHandle(zOvl.hEvent);
    CloseHandle(RxOvl.hEvent);
    FFinished:= True;
  end;
end;// 注意: Destroy 拆构包含对 TTxThd 类的方法destructor TRxThd.Destroy;
begin
  if (Self is TTxThd) then begin
    FOwner.FThd[0]:= nil;
    with TTxThd(Self) do begin
      CloseHandle(FRunSignal);
      with FBuff do if pBuff <> nil then FreeMem(pBuff);
    end;
  end else begin
    FOwner.FThd[1]:= nil;
  end;
  inherited;
end;{ TTxThd }procedure TTxThd.InitParams;
begin
  zInitDataBuf(FBuff, FOwner.TxQueSize);
  DWORD(Que):= 0;
  FRunSignal:= CreateEvent(nil, True, False, nil);
  Que.Idle:= True;
  FOwner.FThd[0]:= Self;
end;procedure TTxThd.AddTxData(pData: PCommTxFrmBuf);
begin
  if FFinished then Exit; // 安全!
  FTxQue[Que.vIn]:= pData;
  Inc(Que.vIn);
  SetEvent(FRunSignal);
end;procedure TTxThd.Execute;
var
  MsgW: TMsgWParam;
  IntW: Integer absolute MsgW;  P: PWORDARRAY;
  IntP: Integer absolute P;  pOvl: POverlapped;
  zHandles: array[0..1] of THandle;{$IFDEF VER100}
  zWritten: Integer;  // for D3
{$ELSE}
  zWritten: Cardinal; // for D4+
{$ENDIF}
begin
  IntW:= 0;
  with FOwner do begin
    ResetEvent(FTxOvl.hEvent);
    pOvl:= @FTxOvl;
    zHandles[1]:= FStopEvent;  // 强制退出的事件
    MsgW.PortIndex:= F.nIndex; // 消息携带内部序号
  end;
  try repeat
    zHandles[0]:= FRunSignal; // 空闲循环(等待加载发送)
    case WaitForMultipleObjects(2, @zHandles, False, INFINITE) of
      WAIT_OBJECT_0: begin // 发送加载!(FRunSignal Set)
        Que.Idle:= False;  // 置"忙"
        ResetEvent(FRunSignal); // 随后的加载再SetEvent(在AddTxData)
        with pOvl^ do begin
          zHandles[0]:= hEvent; // 替换条件(发送完毕事件)
          ResetEvent(hEvent);
        end;
        while Que.vIn <> Que.vOut do begin // 发送循环: 一直发送到队列空
          P:= FTxQue[Que.vOut]; // 取发送队列
          MsgW.TxError:= True;  // 假定不成功
          if WriteFile(FOwner.FCommFile, P^[2], P^[0], zWritten, pOvl) then
            case WaitForMultipleObjects(2, @zHandles, False, INFINITE) of
              WAIT_OBJECT_0: begin
                MsgW.TxError:= not GetOverlappedResult(FOwner.FCommFile, pOvl^, zWritten, False);
              end;
              WAIT_OBJECT_0+1: Exit; // 强制退出!(FStopEvent!)
            end
          else begin
            IntP:= GetLastError;
            MsgW.bMsg:= cvmError1;
            PostMessage(FMsgWnd, FMsgNum, IntW, IntP);
          end;
          if MsgW.TxError then begin
            PurgeComm(FOwner.FCommFile, PURGE_TXABORT or PURGE_TXCLEAR);
          end;
          MsgW.IsFrmId:= False;
          if (IntP >= FBuff.nBuff) and (IntP < FBuff.nDataZ) then begin
            // 缓冲区不需要释放(在内部环形缓冲区)
            IntP:= P^[1]; // LParam 中为帧序号
            MsgW.IsFrmId:= True;
          end;
          PostMessage(FMsgWnd, FMsgNum, IntW, IntP);
          Inc(Que.vOut);
        end;// 发送循环
        Que.Idle:= True;
      end;//WAIT_OBJECT_0
      WAIT_OBJECT_0+1: Break; // 强制退出!(FStopEvent!)
    end;//case
  until FOwner.FWantClose; // 外循环(等待加载数据)
  finally
    PurgeComm(FOwner.FCommFile, PURGE_TXABORT or PURGE_TXCLEAR);
    FFinished:= True;
  end;
end;// 应用退出时的清理, 快速停止所有线程procedure zFreeOnAppExit;
var
  I, J: Integer;
  V: TCommPortz;
  zFinished: Boolean;
begin
  // 全局清除, 让线程快速停止!
  for I:= (FList.Count - 1) downto 0 do begin
    V:= FList[I];
    if Assigned(V) then with V do begin
      FWantClose:= True;
      if Openned then SetEvent(FStopEvent); // 全部线程发出停止信号!
    end;
  end;
  for J:= 49 downto 0 do begin // 5秒限时
    zFinished:= True;
    for I:= (FList.Count - 1) downto 0 do begin
      V:= FList[I];
      if Assigned(V) then zFinished:= V.zThreadsFinished;
      if not zFinished then Break; // 线程未停止, 等待100毫秒后再检查
    end;
    if zFinished then Break; // 线程已全部停止
    Sleep(100);
  end;
  for I:= (FList.Count - 1) downto 0 do begin
    V:= FList[I];
    if Assigned(V) then V.Free;
  end;
  FList.Free;
  FreeMem(FRxBuff.pBuff);
  DeleteCriticalSection(FCritical);
end;initialization
  FList:= nil;finalization
  if Assigned(FList) then zFreeOnAppExit;end.

调试易

求一个API函数写串口的源代码

解决方案 »