unidevice_tapi.pas

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

{******************************************************************}
{                     TAPI Interface                               }
{     Copyright (C) 2000-2001 AT Corp, All rights reserved         }
{          Reference: MSDN, TurboPower's AsyncPro                  }
{                                                                  }
{                  Version 1.07                                    }
{  Compatible Platform : Win97/98/Me/NT4/2K                        }
{                        Windows95 not tested yet                  }
{  Requirement: Nothing                                            }
{                                                                  }
{  fate? maybe......                                               }
{                                                    Cheer Wind    }
{                                                     2000/9/19    }
{                                                                  }
{******************************************************************}

{***************** Development History ****************************}
{  2000/9/19  Start up project                                     }
{  2001/6/13  minor update                                         }
{  2001/6/26  WaitForReply function fixed                          }
{  2001/8/7   CriticalSection only effect on Thread,               }
{             Replaced with Semaphore                              }
{******************************************************************}

unit UniDevice_TAPI;

//{$DEFINE TapiDebug}

interface

uses Windows, Classes, Sysutils, Forms, ExtCtrls, Syncobjs,
  UniCommX, UniInterface_TAPI;

type

  TCustomTAPIDriver = class;

  TTapiCallState = (tsIdle, tsOffering, tsAccepted, tsDialTone, tsDialing,
    tsRingback, tsBusy, tsSpecialInfo, tsConnected,
    tsProceeding, tsOnHold, tsConferenced, tsOnHoldPendConf,
    tsOnHoldPendTransfer, tsDisconnected, tsUnknown);

  {TAPI status event}
  TTapiStatusEvent = procedure(Sender: TObject; First, Last: Boolean; Device, Message, Param1, Param2, Param3: DWORD) of object;
  TTapiHangupEvent = procedure(Sender: TObject; reason: string) of object;
  TTAPIRxCharEvent = procedure(Sender: TObject; Count: Integer) of object;

  // TAPI 驱动线程.主要作用为监控 TAPI 设备的数据接收事件
  TTAPIThread = class(TThread)
  private
    FHCommFile: DWord;
    FCustomTAPIDriver: TCustomTAPIDriver;
    FStopEvent: THandle;
  protected
    procedure Execute; override;
    procedure Stop;
  public
    constructor Create(CustomTAPIDriver: TCustomTAPIDriver; HCommFile: DWord);
    destructor Destroy; override;
  end;

  TCustomTAPIDriver = class(TComponent)
  protected
    { Private declarations }
    LineApp: TLineApp;
    LineHandle: TLine; {当前打开的设备的句柄}
    CallHandle: TCall; {当前Call的句柄}
    LineExt: TLineExtensionID;
    StoppingCall: Boolean; //是否正在挂机
    FConnected: Boolean; {是否正在连接中}
    FDeviceCount: DWORD;
    FApiVersion: LongInt; // 协商TAPI版本
    FAllTAPIDevices: TStrings; // 所有TAPI设备
    FCallInfo: PCallInfo; {保存当前呼叫信息}
    VS: TVarString; {用来取得线路句柄}
    HLineID: DWord;
    FEventThread: TTAPIThread;
    ReplyWait: Boolean; {是否正在等待系统回应}

    RequestedID: LongInt;
    AsyncReplyReceived: Boolean;
    AsyncReplyData: LongInt; {Requested reply}
    CallStateReceived: Boolean; {True if CallState received}
    CallState: LongInt; {Received CallState}

    {Property var}
    FSelectedDevice: string;
    FTapiDevices: TStrings; // 所有Modem类型TAPI设备
    FAutoAnswer: Boolean; // 是否自动应答
    FAnsRings: Integer; // 自动应答振铃次数
    FSem: THandle;

    FDeviceOpened: Boolean;

    {Event Handle}
    Event_ShutDown: DWORD;

    {Events}
    FOnTapiStatus: TTapiStatusEvent;
    FOnTapiConnect: TNotifyEvent;
    FOnTapiHangup: TTapiHangupEvent;
    FOnRxChar: TTAPIRxCharEvent;

    {Callback virtual methods}
    procedure DoLineCallState(Device, P1, P2, P3: LongInt); virtual;
    procedure DoLineClose(Device, P1, P2, P3: LongInt); virtual;
    procedure DoLineCreate(Device, P1, P2, P3: LongInt); virtual;
    procedure DoLineDevState(Device, P1, P2, P3: LongInt); virtual;
    procedure DoLineReply(Device, P1, P2, P3: LongInt); virtual;

    {private function & procedure}
    function GetCallState: TTapiCallState;
    function WaitForReply(ID: LongInt): LongInt;
    function WaitForCallState(DesiredCallState: LongInt): LongInt;
    procedure NotifyTAPIStatus(First, Last: Boolean; Device, Message, Param1, Param2, Param3: DWORD);
    procedure UpdateCallInfo(Device: LongInt);
    procedure NotifyTapiConnect;
    procedure NotifyTapiHangup(reason: string);
    procedure EnumLineDevices;
    procedure SetSelectedDevice(value: string);
    function GetLineID: DWord;
    procedure CallRxChar;
    function WaitForAsync(var Overlapped: TOverlapped): Integer;
    function DeviceIDFromName(const Name: string): Integer;
    procedure Lock;
    procedure UnLock;

  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function Startup: Boolean;
    function ShutDown: Boolean;
    function OpenSelectedDevice: Boolean;
    function CloseSelectedDevice: Boolean;
    procedure Call(Phone: string);
    function Hangup(reason: string = '?'): Boolean;
    function BPS: DWORD;
    function Read(var Buffer; Count: Integer): Integer;
    function Write(const Buffer; Count: Integer): Integer;
    function InputCount: Integer;

  published
    property DeviceOpened: Boolean read FDeviceOpened;
    property TAPICallState: TTapiCallState read GetCallState;
    property TapiDevices: TStrings read FTapiDevices;
    property AutoAnswer: Boolean read FAutoAnswer write FAutoAnswer;
    property AnsRings: Integer read FAnsRings write FAnsRings;
    property SelectedDevice: string read FSelectedDevice write SetSelectedDevice;
    property Connected: Boolean read FConnected;
    property OnTapiStatus: TTapiStatusEvent read FOnTapiStatus write FOnTapiStatus;
    property OnTapiConnect: TNotifyEvent read FOnTapiConnect write FOnTapiConnect;
    property OnTapiHangup: TTapiHangupEvent read FOnTapiHangup write FOnTapiHangup;
    property OnRxChar: TTAPIRxCharEvent read FOnRxChar write FOnRxChar;
  end;

  TDaemonTimerState = (tsPrepare, tsSlience, tsSwitch, tsSendCmd, tsCheckConnection, tsWaitForLineSilence);
  TTAPICommDevice = class(TCustomCommDevice)
  protected
    FDaemonTimer: TTimer;
    FDaemonTimerState: TDaemonTimerState;
    FInTimer: Boolean;
    FTAPIDriver: TCustomTAPIDriver;
    FTAPI_Already_HangUped: Boolean;
    FSem: Thandle;
    FLastConnectionTime: DWord;
    InInternalBusy: Boolean;
    procedure TAPIHangup(Sender: TObject; reason: string);
    procedure TAPIConnect(Sender: TObject);
    procedure TAPIStatus(Sender: TObject; First, Last: Boolean; Device, Message, Param1, Param2, Param3: DWORD);
    procedure OnDaemonTimer(Sender: TObject); virtual;
    procedure SetActived(value: Boolean); override;
    procedure SetBaudRate(value: TUniBaudRate); override;
    procedure SetDeviceName(value: string); override;
    procedure CommRxChar(Sender: TObject; Count: Integer); virtual;
    procedure OpenDevice; override;
    procedure CloseDevice; override;
    function GetBusy: Boolean; override;
    procedure Lock;
    procedure UnLock;
  public
    constructor Create; override;
    destructor Destroy; override;
    class function TypeImplemented(value: TUniDeviceType): Boolean; override;
    class procedure EnumDevice(Device: TStrings); override;
    function InitiativelyConnect(Params: string): Boolean; override;
    procedure CloseConnection; override;
    procedure SendData(Data: string); override;
    function GetDataAndClearBuf: string; override;
  published
    property Actived;
    property BaudRate;
    property DeviceName;
    property DeviceType;
    property Busy;
    property OnInitState;
    property OnConnectState;
    property OnDataArrive;
  end;

implementation

const

  AsyncTimeOut = INFINITE;
  Success = 0;
  WaitErr_WaitAborted = 1;
  WaitErr_WaitTimedOut = 2;
  WaitTimeout = 5000;
  LineCallState_Any = 0;
  Default_Answer_Rings = 2;
  nullDevice = 'Current Device NOT Exists';
  Separater = '-----------------------------------------------------------------------';

procedure GenCallback(Device, Message, Instance, Param1, Param2, Param3: LongInt); stdcall;
{回调程序。初始化TAPI时需要。所有TAPI消息的入口。}
var
  TD: TCustomTAPIDriver absolute Instance;
begin
  TAPILog(Separater);
  TAPILog('Callback. Device: ' + IntToHex(Device, 4) + '  Message: ' + IntToHex(Message, 4) +
    ' P1,P2,P3: ' + IntToHex(Param1, 4) + ' ' + IntToHex(Param2, 4) + ' ' + IntToHex(Param3, 4));
  case Message of
    Line_AddressState: TAPILog('  Line_AddressState message');
    Line_CallInfo: TAPILog('  Line_CallInfo message');
    Line_Callstate:
      begin
        TAPILog('Line_Callstate message：');
        case Param1 of
          LINECALLSTATE_IDLE: TAPILog('IDLE');
          LINECALLSTATE_OFFERING: TAPILog('Offer Ring');
          LINECALLSTATE_ACCEPTED: TAPILog('Accepted');
          LINECALLSTATE_DIALTONE: TAPILog('DialTone');
          LINECALLSTATE_DIALING: TAPILog('Dialing');
          LINECALLSTATE_RINGBACK: TAPILog('RingBack');
          LINECALLSTATE_BUSY: TAPILog('Busy');
          LINECALLSTATE_SPECIALINFO: TAPILog('SpecialInfo');
          LINECALLSTATE_CONNECTED: TAPILog('Connected');
          LINECALLSTATE_PROCEEDING: TAPILog('Proceeding');
          LINECALLSTATE_ONHOLD: TAPILog('ON Hold');
          LINECALLSTATE_CONFERENCED: TAPILog('Conferenced');
          LINECALLSTATE_ONHOLDPENDCONF: TAPILog('OnHoldPendconf');
          LINECALLSTATE_DISCONNECTED: TAPILog('Disconnected');
          LINECALLSTATE_UNKNOWN: TAPILog('Unknown');
        end;
      end;
    Line_Close: TAPILog('Line_Close message');
    Line_DevSpecific: TAPILog('  Line_DevSpecific message');
    Line_DevSpecificFeature: TAPILog('  Line_DevSpecificFeature message');
    Line_Generate: TAPILog('  Line_Generate message');
    Line_LineDevState: TAPILog('  Line_LineDevState message');
    Line_Reply: TAPILog('  Line_Reply message');
    Line_Request: TAPILog('  Line_Request message');
    Line_Create: TAPILog('  Line_Create message');
  end;

  if TD = nil then
  begin
    TAPILog('Error: TAPIDevice is Null');
    Exit;
  end;

  with TD do
  try
    case Message of
      Line_Reply:
        DoLineReply(Device, Param1, Param2, Param3);
      Line_CallState:
        DoLineCallState(Device, Param1, Param2, Param3);
      Line_Close:
        DoLineClose(Device, Param1, Param2, Param3);
      Line_LineDevState:
        DoLineDevState(Device, Param1, Param2, Param3);
      Line_Create:
        DoLineCreate(Device, Param1, Param2, Param3);
    end;
  except
  end;
end;

constructor TTAPIThread.Create(CustomTAPIDriver: TCustomTAPIDriver; HCommFile: DWord);
const
  dcb_Null = $00000800;
var
  DCB: TDCB;
begin
  inherited Create(True);
  Priority := tpHighest;
  FStopEvent := CreateEvent(nil, True, False, nil);
  FHCommFile := HCommFile;
  FCustomTAPIDriver := CustomTAPIDriver;
  SetCommMask(FHCommFile, EV_RXCHAR or EV_TXEMPTY);
  GetCommState(FHCommFile, DCB);
  DCB.Flags := DCB.Flags and (not dcb_Null);
  SetCommState(FHCommFile, DCB);
  Resume;
end;

destructor TTAPIThread.Destroy;
begin
  Stop;
  inherited Destroy;
end;

procedure TTAPIThread.Execute;
var
  EventHandles: array[0..1] of THandle;
  Overlapped: TOverlapped;
  Signaled, BytesTrans, Mask: DWORD;
begin
  FillChar(Overlapped, SizeOf(Overlapped), 0);
  Overlapped.hEvent := CreateEvent(nil, True, True, nil);
  EventHandles[0] := FStopEvent;
  EventHandles[1] := Overlapped.hEvent;
  Signaled := WAIT_OBJECT_0 + 1;
  repeat
    if FHCommFile = INVALID_HANDLE_VALUE then Break;
    WaitCommEvent(FHCommFile, Mask, @Overlapped);
    Signaled := WaitForMultipleObjects(2, @EventHandles, False, INFINITE);
    if (Signaled = WAIT_OBJECT_0 + 1)
      and GetOverlappedResult(FHCommFile, Overlapped, BytesTrans, False) then
    begin
      if (EV_RXCHAR and Mask) <> 0 then
        FCustomTAPIDriver.CallRxChar;
    end;
  until (Signaled <> (WAIT_OBJECT_0 + 1));
  if (FHCommFile <> INVALID_HANDLE_VALUE) then
  begin
    SetCommMask(FHCommFile, 0);
    PurgeComm(FHCommFile, PURGE_TXCLEAR or PURGE_RXCLEAR);
  end;
  CloseHandle(Overlapped.hEvent);
  CloseHandle(FStopEvent);
end;

// stop thread

procedure TTAPIThread.Stop;
begin
  SetEvent(FStopEvent);
  while Suspended do
    Resume;
  Sleep(0);
end;

constructor TCustomTAPIDriver.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FTapiDevices := TStringList.Create;
  FAllTapiDevices := TStringList.Create;
  FillChar(LineExt, SizeOf(LineExt), 0);
  LineApp := 0;
  LineHandle := 0;
  CallHandle := 0;
  FConnected := False;
  HLineID := INVALID_HANDLE_VALUE;
  FSelectedDevice := '';
  FCallInfo := nil;
  FAutoAnswer := True;
  FAnsRings := 2;
  FDeviceOpened := False;
  Event_ShutDown := CreateEvent(nil, False, False, nil);
  FSem := CreateSemaphore(nil, 1, 1, nil);
  if not (csDesigning in ComponentState) then
  begin
    Startup;
    EnumLineDevices;
  end;
end;

destructor TCustomTAPIDriver.Destroy;
begin
  TAPILog(Separater);
  TAPILog('TAPI Device Destroy');
  ShutDown;
  FTapiDevices.Free;
  FAllTapiDevices.Free;
  CloseHandle(Event_ShutDown);
  if Assigned(FCallInfo) then
  begin
    FreeMem(FCallInfo, FCallInfo^.TotalSize);
    FCallInfo := nil;
  end;
  CloseHandle(FSem);
  inherited Destroy;
end;

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

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

function TCustomTAPIDriver.Startup: Boolean;
{初始化 TAPI}
var
  lResult: LongInt;
begin
  // 如已经初始化过，则不再初始化
  if LineApp <> 0 then
  begin
    Result := True;
    Exit;
  end;
  Result := False;
  LineHandle := 0;
  CallHandle := 0;
  lResult := tuLineInitialize(LineApp, hInstance, GenCallBack, 'Universal Communication TAPI Interface', FDeviceCount);
  // 如需要重新启动，则等待5秒钟
  if lResult = LineErr_ReInit then
  begin
    if WaitForSingleObject(Event_ShutDown, 5000) = Wait_Object_0 then Exit;
    lResult := tuLineInitialize(LineApp, hInstance, GenCallBack, nil, FDeviceCount);
  end;
  Result := lResult = Success;
end;

function TCustomTAPIDriver.ShutDown: Boolean;
{终止 TAPI}
begin
  SetEvent(Event_ShutDown);
  Sleep(0);
  if LineApp = 0 then
    Result := True {尚未初始化，无须终止}
  else
  begin
    TAPILog('ShutDown: Close Selected Device');
    CloseSelectedDevice;
    Result := tuLineShutdown(LineApp) = Success;
  end;
end;

procedure TCustomTAPIDriver.EnumLineDevices;
{ 取得所有TAPI设备名称}
var
  I: Integer;
  LineCaps: PLineDevCaps;
  S: string;
  isModem: Boolean;
begin
  FTapiDevices.Clear;
  for I := 1 to FDeviceCount do
  begin
    if tuLineNegotiateApiVersion(LineApp, I - 1, TapiLowVer, TapiHighVer, FApiVersion, LineExt) = 0 then
    begin
      LineCaps := nil;
      try
        if tuLineGetDevCapsDyn(LineApp, I - 1, FApiVersion, 0, LineCaps) <> 0 then Exit;
        if not Assigned(LineCaps) then Exit;
        with LineCaps^ do
        begin
          isModem := (MediaModes and LINEMEDIAMODE_DATAMODEM) = LINEMEDIAMODE_DATAMODEM;
          SetLength(S, LineNameSize);
          Move(LineCaps^.Data[LineNameOffset], PChar(S)^, LineNameSize);
        end;

        if s = '' then s := nullDevice;
        // 添加前导括号，以便辨识所选择的设备
        // s := '(' + IntToStr(I) + ') ' + s;
        //FALLTapiDevices 中存放全部设备， 而FTapiDevices中只存放Modem设备
        FAllTapiDevices.Add(Copy(S, 1, Length(S) - 1));
        if isModem then
          FTapiDevices.Add(Copy(S, 1, Length(S) - 1));
      finally