connect.pas

一个delphi使用的传送短信(SMS)到GSM手机的单元及示范.

begin
  if not FileExists(LogFile) then
  begin
    with TFileStream.Create(LogFile, fmCreate) do
    try
    finally
      Free;
    end;
  end;
  FLogStream:= TFileStream.Create(LogFile, fmOpenWrite or fmShareDenyWrite);
  inherited;
end;

procedure TFileLogger.CloseConn;
begin
  FLogStream.Free;
end;

procedure TLogConnection.DoFormatLog;
begin
  if Assigned(FOnFormatLog) then
    FOnFormatLog(Self, aChannel, aText);
end;

procedure TLogConnection.Log;
begin
  DoFormatLog(aChannel, aText);
  if FLogger <> nil then
    FLogger.Log(FLogName, aChannel, aText);
end;

function TCommunicationConnection.Send;
begin
  Result:= Write(S[1], Length(S));
end;

function TCommunicationConnection.Retrieve;
begin
  SetLength(Result, aCount);  { alloc buffer }
  SetLength(Result, Read(Result[1], aCount));
end;

const
  CommEventList: array[TCommEventType] of dword = (EV_BREAK, EV_CTS, EV_DSR, EV_ERR, EV_RING, EV_RLSD, EV_RXCHAR, EV_RXFLAG, EV_TXEMPTY);

constructor TCommEventThread.Create(aComm: TCommHandle; Handle: THandle; Events: TCommEventTypes);
var
  EvIndex: TCommEventType;
  AttrWord: dword;
begin
  Priority := tpHigher;
  FreeOnTerminate := True;
  FCommHandle := Handle;
  AttrWord := $0;
  for EvIndex := Low(TCommEventType) to High(TCommEventType) do
    if EvIndex in Events then AttrWord := AttrWord or CommEventList[EvIndex];
  SetCommMask(FCommHandle, AttrWord);
  FEvent := TSimpleEvent.Create;
  FComm:= aComm;
  inherited Create(False);
end;

destructor TCommEventThread.Destroy;
begin
  FEvent.Free;
  Inherited Destroy;
end;

procedure TCommEventThread.Execute;
var
  Overlapped: TOverlapped;
  WaitEventResult: Boolean;
begin
  FillChar(Overlapped, Sizeof(Overlapped), 0);
  Overlapped.hEvent:= FEvent.Handle;
  while not Terminated do
  begin
    WaitEventResult:= WaitCommEvent(FCommHandle, FEventMask, @Overlapped);
    if (GetLastError = ERROR_IO_PENDING) then
      WaitEventResult:= (FEvent.WaitFor(INFINITE) = wrSignaled);
    if WaitEventResult then
    begin
      if FComm.FDontSynchronize then DoOnSignal
                                else Synchronize(DoOnSignal);
      FEvent.ResetEvent;
    end;
  end;
  PurgeComm(FCommHandle, PURGE_RXABORT+PURGE_RXCLEAR+PURGE_TXABORT+PURGE_TXCLEAR);
end;

procedure TCommEventThread.Terminate;
begin
  FEvent.SetEvent;
  inherited;
end;

procedure TCommEventThread.DoOnSignal;
begin
  FComm.HandleCommEvent(FEventMask);
end;

const
  fBinary              = $00000001;
  fParity              = $00000002;
  fOutxCtsFlow         = $00000004;
  fOutxDsrFlow         = $00000008;
  fDtrControl          = $00000030;
  fDtrControlDisable   = $00000000;
  fDtrControlEnable    = $00000010;
  fDtrControlHandshake = $00000020;
  fDsrSensitivity      = $00000040;
  fTXContinueOnXoff    = $00000080;
  fOutX                = $00000100;
  fInX                 = $00000200;
  fErrorChar           = $00000400;
  fNull                = $00000800;
  fRtsControl          = $00003000;
  fRtsControlDisable   = $00000000;
  fRtsControlEnable    = $00001000;
  fRtsControlHandshake = $00002000;
  fRtsControlToggle    = $00003000;
  fAbortOnError        = $00004000;
  fDummy2              = $FFFF8000;

constructor TCommHandle.Create;
begin
  inherited Create(AOwner);
  FhCommDev:= INVALID_HANDLE_VALUE;
  FReadTimeout := 1000;
  FWriteTimeout := 1000;
  FReadBufSize := 4096;
  FWriteBufSize := 2048;
  FMonitorEvents := [evBreak, evCts, evDsr, evError, evRing,
    evRlsd, evRxChar, evRxFlag, evTxEmpty];
  FBaudRate := br9600;
  FParity := paNone;
  FStopbits := sb10;
  FDatabits := da8;
  FOptions := [];
  FFlowControl := fcDefault;
  XonChar := #17;
  XoffChar := #19;
  FEvent := TSimpleEvent.Create;
  FCriticalSection := TCriticalSection.Create;
end;

destructor TCommHandle.Destroy;
begin
  inherited Destroy;
  FEvent.Free;
  FCriticalSection.Free;
end;

procedure TCommHandle.SethCommDev(Value: THandle);
begin
  CheckInactive;
  FhCommDev:= Value;
end;

procedure TCommHandle.SetBaudRate(Value: TBaudRate);
begin
  if FBaudRate <> Value then
  begin
    FBaudRate := Value;
    UpdateDataControlBlock;
  end;
end;

procedure TCommHandle.SetParity(Value: TParity);
begin
  if FParity <> Value then
  begin
    FParity := Value;
    UpdateDataControlBlock;
  end;
end;

procedure TCommHandle.SetStopbits(Value: TStopbits);
begin
  if FStopBits <> Value then
  begin
    FStopbits := Value;
    UpdateDataControlBlock;
  end;
end;

procedure TCommHandle.SetDataBits(Value: TDatabits);
begin
  if FDataBits <> Value then
  begin
    FDataBits:=Value;
    UpdateDataControlBlock;
  end;
end;

procedure TCommHandle.SetOptions(Value: TCommOptions);
begin
  if FOptions <> Value then
  begin
    FOptions := Value;
    UpdateDataControlBlock;
  end;
end;

procedure TCommHandle.SetFlowControl(Value: TFlowControl);
begin
  if FFlowControl <> Value then
  begin
    FFlowControl := Value;
    UpdateDataControlBlock;
  end;
end;

function TCommHandle.GetEventChar;
begin
  Result:= FEventChars[Index];
end;

procedure TCommHandle.SetEventChar;
begin
  if FEventChars[Index] <> Value then
  begin
    FEventChars[Index]:= Value;
    UpdateDataControlBlock;
  end;
end;

procedure TCommHandle.SetReadBufSize(Value: Integer);
begin
  CheckInactive;
  FReadBufSize:= Value;
end;

procedure TCommHandle.SetWriteBufSize(Value: Integer);
begin
  CheckInactive;
  FWriteBufSize:= Value;
end;

procedure TCommHandle.SetMonitorEvents(Value: TCommEventTypes);
begin
  CheckInactive;
  FMonitorEvents := Value;
end;

procedure TCommHandle.Lock;
begin
  FCriticalSection.Enter;
end;

procedure TCommHandle.Unlock;
begin
  FCriticalSection.Leave;
end;

procedure TCommHandle.OpenConn;
begin
  if FhCommDev = INVALID_HANDLE_VALUE then
    ComError2('CreateFile');

  if GetFileType(FhCommDev) <> FILE_TYPE_CHAR then
  begin
    CloseHandle(FhCommDev);
    FhCommDev:= INVALID_HANDLE_VALUE;
    ComError2('GetFileType');
  end;

  FEventThread:= TCommEventThread.Create(Self, FhCommDev, FMonitorEvents);
  UpdateCommTimeouts;
  UpdateDCB;         

  if not SetupComm(FhCommDev, FReadBufSize, FWriteBufSize) then
    ComError2('SetupComm');
end;

procedure TCommHandle.CloseConn;
begin
  if FhCommDev <> INVALID_HANDLE_VALUE then
  begin
    FEventThread.Terminate;
    CloseHandle(FhCommDev);
    FhCommDev:= INVALID_HANDLE_VALUE;
  end;
end;

function TCommHandle.Write(const Buf; Count: Integer): Integer;
var
  Overlapped: TOverlapped;
begin
  Lock;
  try
    FillChar(Overlapped, Sizeof(Overlapped), 0);
    Overlapped.hEvent := FEvent.Handle;
    if not WriteFile(FhCommDev, Buf, Count, dWord(Result), @Overlapped) and (GetLastError <> ERROR_IO_PENDING) then
      ComError2('WriteFile');
    if FEvent.WaitFor(FWriteTimeout) <> wrSignaled then
      Result:= 0
    else
     begin
       GetOverlappedResult(FhCommDev, Overlapped, dWord(Result), False);
       FEvent.ResetEvent;
     end;
  finally
    Unlock;
  end;
end;

function TCommHandle.Read(var Buf; Count: Integer): Integer;
var
  Overlapped: TOverlapped;
begin
  Lock;
  try
    FillChar(Overlapped, Sizeof(Overlapped), 0);
    Overlapped.hEvent := FEvent.Handle;
    if not ReadFile(FhCommDev, Buf, Count, dWord(Result), @Overlapped) and (GetLastError <> ERROR_IO_PENDING) then
      ComError2('ReadFile');
    if FEvent.WaitFor(FReadTimeout) <> wrSignaled then
      Result:= 0
    else
     begin
       GetOverlappedResult(FhCommDev, Overlapped, dWord(Result), False);
       FEvent.ResetEvent;
     end;
  finally
    Unlock;
  end;
end;

function TCommHandle.InQueCount: Integer;
var
  ComStat: TComStat;
  Errors: dword;
begin
  if Active then
  begin
    ClearCommError(FhCommDev, Errors, @ComStat);
    Result:= ComStat.cbInQue;
  end else Result:= -1;
end;

function TCommHandle.OutQueCount: Integer;
var
  ComStat: TComStat;
  Errors: dword;
begin
  if Active then
  begin
    ClearCommError(FhCommDev, Errors, @ComStat);
    Result:= ComStat.cbOutQue;
  end else Result:= -1;
end;

procedure TCommHandle.HandleCommEvent;
var
  ComStat: TComStat;
  Errors: dword;
begin
  ClearCommError(FhCommDev, Errors, @ComStat);
  if Status and EV_BREAK > 0 then
    if Assigned(FOnBreak) then FOnBreak(self);
  if Status and EV_CTS > 0 then
    if Assigned(FOnCts) then FOnCts(self);
  if Status and EV_DSR > 0 then
    if Assigned(FOnDsr) then FOnDsr(self);
  if Status and EV_ERR > 0 then
    if Assigned(FOnError) then FOnError(self, Errors);
  if Status and EV_RING > 0 then
    if Assigned(FOnRing) then FOnRing(self);
  if Status and EV_RLSD > 0 then
    if Assigned(FOnRlsd) then FOnRlsd(self);
  if Status and EV_RXCHAR > 0 then
    if ComStat.cbInQue > 0 then
      if Assigned(FOnRxChar) then FOnRxChar(self, ComStat.cbInQue);
  if Status and EV_RXFLAG > 0 then
    if Assigned(FOnRxFlag) then FOnRxFlag(self);
  if Status and EV_TXEMPTY > 0 then
    if Assigned(FOnTxEmpty) then FOnTxEmpty(self);
end;

procedure TCommHandle.EscapeComm(Flag: Integer);
begin
  CheckInactive;
  if not EscapeCommFunction(FhCommDev, Flag) then
    ComError2('EscapeCommFunction');
end;

procedure TCommHandle.SetEsc;
const
  Esc: array[1..4, Boolean] of Integer = ((CLRDTR, SETDTR),(CLRRTS, SETRTS),(CLRBREAK, SETBREAK),(SETXOFF, SETXON));
begin
  EscapeComm(Esc[Index, Value]);
  if Active and (Index = 3) then
    PurgeComm(FhCommDev, PURGE_RXABORT+PURGE_RXCLEAR+PURGE_TXABORT+PURGE_TXCLEAR);
end;

function TCommHandle.GetComState(Index: Integer): Boolean;
var
  ComStat: TComStat;
  Errors: DWord;
begin
  Result := false;
  if Active then
  begin
    if not ClearCommError(FhCommDev, Errors, @ComStat) then
      ComError2('ClearCommError');
    Result:= TComStateFlag(Index) in ComStat.Flags;
  end;
end;

function TCommHandle.GetModemState(Index: Integer): Boolean;
var
  Flag: dword;
begin
  Result:= False;
  if Active then
  begin
    if not GetCommModemStatus(FhCommDev, Flag) then
      ComError2('GetCommModemStatus');
    Result:= (Flag and Index) <> 0;
  end;
end;

procedure TCommHandle.UpdateDataControlBlock;
begin
  if Active then
    UpdateDCB;
end;

procedure TCommHandle.UpdateDCB;
const
  CommBaudRates: array[TBaudRate] of Integer = ( CBR_110, CBR_300, CBR_600, CBR_1200, CBR_2400, CBR_4800, CBR_9600, CBR_14400,
      CBR_19200, CBR_38400, CBR_56000, CBR_57600, CBR_115200, CBR_128000, CBR_256000);
  CommOptions: array[TCommOption] of Integer = (Connect.fParity, fDsrSensitivity, fTXContinueOnXoff, fErrorChar, fNull);
  CommDataBits: array[TDatabits] of Integer = (4, 5, 6, 7, 8);
  CommParity: array[TParity] of Integer = (NOPARITY, ODDPARITY, EVENPARITY, MARKPARITY, SPACEPARITY);
  CommStopBits: array[TStopbits] of Integer = (ONESTOPBIT, ONE5STOPBITS, TWOSTOPBITS);
var
  OptIndex: TCommOption;
  DCB: TDCB;
begin
  GetCommState(FhCommDev, DCB);

  DCB.BaudRate := CommBaudRates[FBaudRate];
  DCB.Parity := CommParity[FParity];
  DCB.Stopbits := CommStopbits[FStopbits];
  DCB.Bytesize := CommDatabits[FDatabits];
  DCB.XonChar := XonChar;
  DCB.XoffChar := XOffChar;
  DCB.ErrorChar := ErrorChar;
  DCB.EofChar := EofChar;
  DCB.EvtChar := EvtChar;
  DCB.XonLim := FReadBufSize div 4;
  DCB.XoffLim := FReadBufSize div 4;

  case FFlowControl of
    fcNone: //Clear all flags
      DCB.Flags := fBinary;
    fcDefault:; //do nothing;
    fcCTS:
      DCB.Flags := DCB.Flags or fOutxCtsFlow or fRtsControlHandshake;
    fcDTR:
      DCB.Flags := DCB.Flags or fOutxDsrFlow or fDtrControlHandshake;
    fcSoftware:
      DCB.Flags := DCB.Flags or fOutX or fInX;
  end;
  for OptIndex := Low(TCommOption) to High(TCommOption) do
    if OptIndex in FOptions then DCB.Flags := DCB.Flags or CommOptions[OptIndex]
                            else DCB.Flags := DCB.Flags and not CommOptions[OptIndex];

  if not SetCommState(FhCommDev, DCB) then
    ComError2('SetCommState');
end;

procedure TCommHandle.UpdateCommTimeouts;
var
  CommTimeouts: TCommTimeouts;
begin
  FillChar(CommTimeOuts, Sizeof(CommTimeOuts), 0);
  CommTimeOuts.ReadIntervalTimeout := MAXDWORD;
  if not SetCommTimeOuts(FhCommDev, CommTimeOuts) then
    ComError2('SetCommTimeouts');
end;

procedure TCommHandle.PurgeIn;
begin
  if Active then
    PurgeComm(FhCommDev, PURGE_RXABORT + PURGE_RXCLEAR);
end;

procedure TCommHandle.PurgeOut;
begin
  if Active then
    PurgeComm(FhCommDev, PURGE_TXABORT + PURGE_TXCLEAR);
end;

constructor TComm.Create;
begin
  inherited Create(AOwner);
  FDeviceName:= DefaultDeviceName;
end;

procedure TComm.SetDeviceName(const Value: string);
begin
  CheckInactive;
  FDeviceName := Value;
end;

procedure TComm.OpenConn;
begin
  FhCommDev := CreateFile(PChar(FDeviceName), GENERIC_READ or GENERIC_WRITE, 0, nil, OPEN_EXISTING, FILE_FLAG_OVERLAPPED, 0);
  inherited;
end;

const
  Bauds: array[br110..br256000] of Longint =
     (110, 300, 600, 1200, 2400, 4800, 9600, 14400, 19200, 38400, 56000, 57600, 115200, 128000, 256000);

function Int2BaudRate(BR1: Longint; var BR: TBaudRate): Boolean;
var
  I: TBaudRate;
begin
  Result:= False;
  for I:= Low(Bauds) to High(Bauds) do
    if Bauds[I] = BR1 then
    begin
      BR:= I;
      Result:= True;
      Break;
    end;
end;

function BaudRate2Int(BR: TBaudRate): Longint;
begin
  Result:= Bauds[BR];
end;

procedure Register;
begin
  RegisterComponents('Communication', [TComm, TFileLogger]);
end;

end.