unidevice_tapi.pas

很好用的串口通信工具软件。Comport目录下是用到的通信控件。

end;

procedure TCustomTAPIDriver.CallRxChar;
var
  Count: Integer;
begin
  Count := InputCount;
  if Count > 0 then
    if Assigned(FOnRxChar) then
      FOnRxChar(self, Count);
end;

function TCustomTAPIDriver.WaitForAsync(var Overlapped: TOverlapped): Integer;
var
  BytesTrans, Signaled: DWORD;
  Success: Boolean;
begin
  Signaled := WaitForSingleObject(Overlapped.hEvent, AsyncTimeOut);
  Success := (Signaled = WAIT_OBJECT_0) and
    (GetOverlappedResult(HLineID, Overlapped, BytesTrans, False));
  if not Success then
    Result := 0
  else
    Result := BytesTrans;
end;

function TCustomTAPIDriver.Read(var Buffer; Count: Integer): Integer;
var
  Overlapped: TOverlapped;
  BytesTrans: DWORD;
begin
  Lock;
  FillChar(Overlapped, SizeOf(TOverlapped), 0);
  try
    Result := 0;
    if not FConnected then Exit;
    if HLineID = INVALID_HANDLE_VALUE then Exit;
    Overlapped.hEvent := CreateEvent(nil, True, True, nil);
    if ReadFile(HLineID, Buffer, Count, BytesTrans, @Overlapped) or (GetLastError = ERROR_IO_PENDING) then
      Result := WaitForAsync(Overlapped);
  finally
    // fixed by cheer 2001.7.20
    if Overlapped.hEvent <> 0 then
      CloseHandle(Overlapped.hEvent);
    UnLock;
  end;
end;

function TCustomTAPIDriver.Write(const Buffer; Count: Integer): Integer;
var
  Overlapped: TOverlapped;
  BytesTrans: DWORD;
begin
  Lock;
  FillChar(Overlapped, SizeOf(TOverlapped), 0);
  try
    Result := 0;
    if not FConnected then Exit;
    if HLineID = INVALID_HANDLE_VALUE then Exit;
    Overlapped.hEvent := CreateEvent(nil, True, True, nil);
    if WriteFile(HLineID, Buffer, Count, BytesTrans, @Overlapped) or (GetLastError = ERROR_IO_PENDING) then
      Result := WaitForAsync(Overlapped);
  finally
    // fixed by cheer 2001.7.20
    if Overlapped.hEvent <> 0 then
      CloseHandle(Overlapped.hEvent);
    UnLock;
  end;
end;

function TCustomTAPIDriver.DeviceIDFromName(const Name: string): Integer;
var
  I: Integer;
  LineCaps: PLineDevCaps;
  S: string;
begin
  Startup;

  if Name = '' then
  begin
    Result := -1;
    Exit;
  end;

    {Enumerate all line devices and build a list of names}
  for I := 1 to FDeviceCount do
  begin
    try
      LineCaps := nil;
      if tuLineNegotiateApiVersion(LineApp, I - 1, TapiLowVer,
        TapiHighVer, FApiVersion, LineExt) = 0 then
      begin
        tuLineGetDevCapsDyn(LineApp, I - 1, FApiVersion, 0, LineCaps);
        if not Assigned(LineCaps) then
        begin
          Result := -1;
          Exit;
        end;
        with LineCaps^ do
        begin
          SetLength(S, LineNameSize - 1);
          Move(LineCaps^.Data[LineNameOffset], PChar(S)^, LineNameSize);
          if Name = S then
          begin
            Result := I - 1;
            Exit;
          end;
        end;
      end;
    finally
      if Assigned(LineCaps) then
        FreeMem(LineCaps, LineCaps^.TotalSize);
    end;
  end;
  Result := -1;
end;

{*********************************************************************
                           TAPICommDevice
*********************************************************************}

constructor TTAPICommDevice.Create;
begin
  inherited;
  // 主动要求连接的超时为60秒
  FInitiativeTimeOut := 60000;
  FTAPIDriver := TCustomTAPIDriver.Create(nil);
  with FTAPIDriver do
  begin
    OnRxChar := CommRxChar;
    OnTAPIHangup := TAPIHangup;
    OnTAPIConnect := TAPIConnect;
    OnTAPIStatus := TAPIStatus;
  end;
  FDeviceType := dtTAPI;
  FDeviceState := dsIdle;
  InInternalBusy := False;
  // 建立守护时钟
  FDaemonTimer := TTimer.Create(nil);
  FDaemonTimer.Enabled := False;
  FDaemonTimer.OnTimer := OnDaemonTimer;
  // 建立互斥量
  FSem := CreateSemaphore(nil, 1, 1, nil);
  FLastConnectionTime := GetTickCount;
end;

destructor TTAPICommDevice.Destroy;
begin
  CloseDevice;
  FDaemonTimer.Free;
  CloseHandle(FSem);
  inherited;
  with FTAPIDriver do
  begin
    OnRxChar := nil;
    OnTAPIHangup := nil;
    OnTAPIConnect := nil;
    OnTAPIStatus := nil;
    Free;
  end;
  FTAPIDriver := nil;
end;

procedure TTAPICommDevice.Lock;
begin
  WaitForSingleObject(FSem, INFINITE);
end;

procedure TTAPICommDevice.UnLock;
begin
  ReleaseSemaphore(FSem, 1, nil);
end;

procedure TTAPICommDevice.SetActived(value: Boolean);
begin
  if value = false then
  begin
    CloseDevice;
    FActived := value;
  end
  else if FActived <> value then
  begin
    // 注意：如果设定Actived标志为True，Actived标志只有等初始化成功后才真正变为True
    CloseDevice;
    if value then
      OpenDevice
    else
      FActived := False;
  end;
end;

procedure TTAPICommDevice.SetBaudRate(value: TUniBaudRate);
begin
  if value <> FBaudRate then
  begin
    FBaudRate := value;
  end;
end;

procedure TTAPICommDevice.SetDeviceName(value: string);
begin
  if value <> FDeviceName then
  begin
    Actived := False;
    FDeviceName := Value;
  end;
end;

class procedure TTAPICommDevice.EnumDevice(Device: TStrings);
var TAPIDriver: TCustomTAPIDriver;
begin
  TAPIDriver := TCustomTAPIDriver.Create(nil);
  Device.Assign(TAPIDriver.TapiDevices);
  TAPIDriver.Free;
end;

function TTAPICommDevice.GetBusy: Boolean;
begin
  Result := inherited GetBusy;
  if InInternalBusy then Result := True;
end;

class function TTAPICommDevice.TypeImplemented(value: TUniDeviceType): Boolean;
begin
  Result := value = dtTAPI;
end;

function TTAPICommDevice.InitiativelyConnect(Params: string): Boolean;
begin
  Result := inherited InitiativelyConnect(Params);
  if Busy or (not Actived) then Exit;
  FTAPIDriver.Call(Params);
  InitiativelyConnecting := True;
  Result := True;
end;

procedure TTAPICommDevice.SendData(Data: string);
begin
  FTAPIDriver.Write(Data[1], length(Data));
  Debug(DeviceName, '==> ' + ConvBinaryToHexStr(Data));
end;

procedure TTAPICommDevice.CloseConnection;
begin
  if not Actived then Exit;
  CloseDevice;
  OpenDevice;
end;

function TTAPICommDevice.GetDataAndClearBuf: string;
begin
  Lock;
  Result := FDatas;
  FDatas := '';
  UnLock;
end;

procedure TTAPICommDevice.CommRxChar(Sender: TObject; Count: Integer);
type
  CharBuf = array[0..MaxInt - 1] of Char;

var
  Buffer: ^CharBuf;
  Bytes, P: Integer;
  Data: string;
begin
  if (FDeviceState <> dsConnected) then
  begin
    GetMem(Buffer, Count);
    FTAPIDriver.Read(Buffer^, Count);
    FreeMem(Buffer);
    Exit;
  end;
  Lock;
  try
    Data := '';
    GetMem(Buffer, Count);
    try
      Fillchar(Buffer^, Count, 0);
      Bytes := FTAPIDriver.Read(Buffer^, Count);
      for P := 0 to Bytes - 1 do
        data := data + CharBuf(Buffer^)[P];
    except
    end;
    Debug(DeviceName, '<== ' + ConvBinaryToHexStr(Data));
    FreeMem(Buffer);
    // 如果已经连接成功，则产生接收到数据事件，否则接收到的数据作为初始化数据保存
    if (FDeviceState = dsConnected) then
    begin
      FDatas := FDatas + data;
      SetEvent(Event_DataArrive);
      NotifyDataArrive(Data);
    end;
  finally
    UnLock;
  end;
end;

procedure TTAPICommDevice.OpenDevice;
begin
  InInternalBusy := False;
  FDaemonTimer.Enabled := False;
  FDaemonTimerState := tsPrepare;
  FDaemonTimer.Interval := 10;
  FDaemonTimer.Enabled := True; // 预先打开守护时钟
end;

procedure TTAPICommDevice.CloseDevice;
begin
  inherited;
  while FInTimer do
    Sleep(1);
  FActived := False;
  FDaemonTimer.Enabled := False;
  TAPILog('CloseDevice: Close Selected Device');
  FTAPIDriver.CloseSelectedDevice;
  FDeviceState := dsIdle;
end;

procedure TTAPICommDevice.TAPIHangup(Sender: TObject; Reason: string);
begin
  FTAPI_Already_HangUped := True;
end;

procedure TTAPICommDevice.TAPIConnect(Sender: TObject);
begin
end;

procedure TTAPICommDevice.TAPIStatus(Sender: TObject; First, Last: Boolean; Device, Message, Param1, Param2, Param3: DWORD);
begin
  // by cheer 2001.7.6
  // 如果检测到振铃，则肯定不是主动拨出造成的，所以将正在主动拨出标志设定为假
  if ((Message = Line_CallState) and (Param1 = LineCallState_Offering)) or
     ((Message = Line_LineDevState) and (Param1 = LineDevState_Ringing)) then
  begin
    InInternalBusy := True;
    InitiativelyConnecting := False;
  end;
end;

procedure TTAPICommDevice.OnDaemonTimer(Sender: TObject);
const
  LineSilenceInterval = 3000;
begin
  FInTimer := True;
  FDaemonTimer.Enabled := False;
  case FDaemonTimerState of
    tsPrepare:
      begin
        InInternalBusy := False;
        try
          TAPILog('OnDeamontimer: Close Selected Device');
          FTAPIDriver.CloseSelectedDevice;
          FTAPIDriver.SelectedDevice := FDeviceName; //此处可能发生异常。原因：设备名称错误
          FDeviceState := dsInitDevice;
          FTAPIDriver.OpenSelectedDevice; //此处可能发生异常。原因：设备已经被占用
          FDaemonTimerState := tsSwitch;
          FDaemonTimer.Interval := 500;
          FDaemonTimer.Enabled := True; // 预先打开守护时钟
        except
          FTAPIDriver.CloseSelectedDevice;
          FDaemonTimerState := tsPrepare;
          FDaemonTimer.Interval := 1000;
          FDaemonTimer.Enabled := True;
        end;
      end;
    tsSwitch:
      begin
        // 检测是否打开成功
        if FTAPIDriver.FDeviceOpened then
        begin
          NotifyInitCompleted(True);
          FDaemonTimer.Interval := 50;
          FDaemonTimer.Enabled := True;
          FDaemonTimerState := tsCheckConnection;
          FTAPI_Already_HangUped := False;
          FDeviceState := dsWaitForConnect;
        end
        else
        begin
          FDeviceState := dsIdle;
          FTAPIDriver.CloseSelectedDevice;
          NotifyInitCompleted(false);
        end;
      end;
    tsWaitForLineSilence:
      begin
        // 如果在静音时间内挂机 cheer 2001.6.29
        if FTAPI_Already_HangUped then
        begin
          FIsInitiative := InitiativelyConnecting;
          NotifyConnection(False);
          InInternalBusy := False;
          InitiativelyConnecting := False;
        end
        else
        begin
          FDeviceState := dsConnected;
          // 检测是否断线
          FDaemonTimerState := tsCheckConnection;
          NotifyConnection(True);
          InInternalBusy := False;
          InitiativelyConnecting := False;
          FDaemonTimer.Interval := 100;
          FDaemonTimer.Enabled := True;
        end;
      end;
    tsCheckConnection:
      begin
        // 或者在5分钟内没有连接成功，可能因为Modem掉电或Modem空闲
        // 在此情况下，需重新初始化
        if (FDeviceState <> dsConnected) and (GetTickCount - FLastConnectionTime > 5 * 60 * 1000) and (not InitiativelyConnecting) then
        begin
          FTAPIDriver.CloseSelectedDevice;
          try
            FTAPIDriver.OpenSelectedDevice;
          except
          end;
          FDaemonTimerState := tsPrepare;
          FLastConnectionTime := GetTickCount;
          FDaemonTimer.Enabled := True;
          InitiativelyConnecting := False;
        end
        else if FTAPI_Already_HangUped and (FDeviceState = dsWaitForConnect) then
        begin
          FIsInitiative := InitiativelyConnecting;
          NotifyConnection(False);
          InInternalBusy := False;
          InitiativelyConnecting := False;
        end
        else if (FDeviceState = dsWaitForConnect) and (FTAPIDriver.Connected) then
        begin
          // 连接成功
          FIsInitiative := InitiativelyConnecting and (GetTickCount - FLastInitiativeTime <= FInitiativeTimeOut);
          FLastConnectionTime := GetTickCount;
          FDaemonTimerState := tsWaitForLineSilence;
          FDaemonTimer.Interval := LineSilenceInterval;
          FDaemonTimer.Enabled := True;
          Debug(DeviceName, '硬件握手成功');
        end
        else if (FDeviceState = dsWaitForConnect) and InitiativelyConnecting and (GetTickCount - FLastInitiativeTime > FInitiativeTimeOut) then
        begin
          FIsInitiative := True;
          NotifyConnection(False);
          InInternalBusy := False;
          InitiativelyConnecting := False;
        end
        else if (FDeviceState = dsConnected) and (not FTAPIDriver.Connected) then
        begin
          NotifyConnection(False);
          InInternalBusy := False;
          InitiativelyConnecting := False;
        end
        else
          FDaemonTimer.Enabled := True;
      end;
  end;
  FInTimer := False;
end;

initialization
  // 注册设备类型
  RegisterDeviceClass(TTAPICommDevice);

end.