smscomm.pas

短信二次开发控件SMSComm

  end
  else
    inherited AssignTo(Dest);
end;


// set parity bits
procedure TComParity.SetBits(const Value: TParityBits);
begin
  if Value <> FBits then
  begin
    FBits := Value;
  end;
end;

// set check parity
procedure TComParity.SetCheck(const Value: Boolean);
begin
  if Value <> FCheck then
  begin
    FCheck := Value;
  end;
end;

// set replace on parity error
procedure TComParity.SetReplace(const Value: Boolean);
begin
  if Value <> FReplace then
  begin
    FReplace := Value;
  end;
end;

// set replace char
procedure TComParity.SetReplaceChar(const Value: Char);
begin
  if Value <> FReplaceChar then
  begin
    FReplaceChar := Value;
  end;
end;


(*****************************************
 * TTimingDelSMS class                   *
 *****************************************)

// create class
constructor TTimingDelSMS.Create(AOwner: TComponent);
var
  CurrentDateTime: TDateTime;
  AYear,AMonth,ADay,AHour,AMinute, ASecond,AMilliSecond: Word;
begin
  inherited Create;
  FOwner := AOwner;
  FTimingDelSMS := True;
  FDelSMSInteval := 12;
  CurrentDateTime := Now;
  DecodeDateTime( CurrentDateTime, AYear, AMonth, ADay, AHour, AMinute, ASecond, AMilliSecond);
  FTimingDelSMSTime := ( ((AHour div FDelSMSInteval) + 1) * FDelSMSInteval ) mod 24;
end;

// copy properties to other class
procedure TTimingDelSMS.AssignTo(Dest: TPersistent);
begin
  if Dest is TTimingDelSMS then
  begin
    with TTimingDelSMS(Dest) do
    begin
      FTimingDelSMS   := Self.TimingDelSMS;
      FDelSMSInteval := Self.DelSMSInteval;
    end
  end
  else
    inherited AssignTo(Dest);
end;


procedure TTimingDelSMS.SetDelSMSInteval(const Value: Integer);
var
  CurrentDateTime: TDateTime;
  AYear,AMonth,ADay,AHour,AMinute, ASecond,AMilliSecond: Word;
begin
  if (Value>24) or (Value<1) then Raise Exception.Create('短信清理周期应该设置在1~24小时之间！');
  FDelSMSInteval := Value;
  CurrentDateTime := Now;
  DecodeDateTime( CurrentDateTime, AYear, AMonth, ADay, AHour, AMinute, ASecond, AMilliSecond);
  FTimingDelSMSTime := ( ((AHour div FDelSMSInteval) + 1) * FDelSMSInteval ) mod 24;
end;


procedure TTimingDelSMS.SetTimingDelSMS(const Value: Boolean);
var
  CurrentDateTime: TDateTime;
  AYear,AMonth,ADay,AHour,AMinute, ASecond,AMilliSecond: Word;
begin
  FTimingDelSMS := Value;
  CurrentDateTime := Now;
  DecodeDateTime( CurrentDateTime, AYear, AMonth, ADay, AHour, AMinute, ASecond, AMilliSecond);
  FTimingDelSMSTime := ( ((AHour div FDelSMSInteval) + 1) * FDelSMSInteval ) mod 24;
end;


(*****************************************
 * TComPort class                        *
 *****************************************)

// create class
constructor TComPort.Create(AOwner: TComponent);
begin
  inherited Create;
  FOwner  := AOwner;
  FBaudRate := br9600;
  FCustomBaudRate := 9600;
  FPort := 'COM1';
  FStopBits := sbOneStopBit;
  FDataBits := dbEight;
  FHandle := INVALID_HANDLE_VALUE;
  FConnected := False;
  FParity := TComParity.Create(Self);
  FTimeouts := TComTimeouts.Create(Self);
  FBuffer   := TComBuffer.Create(Self);
end;

// destroy
destructor TComPort.Destroy;
begin
  Close;
  FBuffer.Free;
  FTimeouts.Free;
  FParity.Free;
  inherited Destroy;
end;

// clear
procedure TComPort.Clear;
begin
  PurgeComm( FHandle, PURGE_TXABORT or PURGE_RXABORT or PURGE_TXCLEAR or PURGE_RXCLEAR ) ;
end;

// open port
procedure TComPort.Open;
begin
  // if already connected, do nothing
  if not FConnected and not (csDesigning in FOwner.ComponentState)
    and not (csLoading in FOwner.ComponentState) then
  begin
    // open port
    CreateHandle;
    FConnected := True;
    try
      // initialize port
      SetupComPort;
    except
      // error occured during initialization, destroy handle
      DestroyHandle;
      FConnected := False;
      raise;
    end;
  end;
end;

// close port
procedure TComPort.Close;
begin
  // if already closed, do nothing
  if FConnected and not (csDesigning in FOwner.ComponentState) and
    not (csLoading in FOwner.ComponentState) then
  begin
    // close port
    DestroyHandle;
    FConnected := False;
    // port is closed, do any additional finalization
  end;
end;

// perform write operation
function TComPort.WriteStr(const Str: string): Boolean;
var
  BytesTrans: DWORD;
begin
  Result := False;
  if Length(Str) > 0 then begin
     Result := WriteFile(FHandle, Str[1], Length(Str), BytesTrans, nil)
                and ( Cardinal(Length(Str)) = BytesTrans);

     {if not Result then
        raise EComPort.Create(CError_WriteFailed, GetLastError);}
   end;
end;

// perform write operation
function TComPort.Write(const Buffer; Count: Integer): Boolean;
var
  BytesTrans: DWORD;
begin
  Result := WriteFile(FHandle, Buffer, Count, BytesTrans, nil)
            and (Cardinal(Count) = BytesTrans);
            
  {if not Result then
     raise EComPort.Create(CError_WriteFailed, GetLastError);}
end;

// perform read operation
function TComPort.Read(var Buffer; Count: Integer): Boolean;
var
  BytesTrans: DWORD;
begin
  Result := ReadFile(FHandle, Buffer, Count, BytesTrans, nil)
            and (Cardinal(Count) = BytesTrans);
  {if not Result then
       raise EComPort.Create(CError_ReadFailed, GetLastError);}
end;

// perform  read operation
function TComPort.ReadStr(var Str: string; Count: Integer): Boolean;
var
  BytesTrans: DWORD;
begin
  Result := False;
  SetLength(Str, Count);
  if Count > 0 then begin
     Result := ReadFile(FHandle, Str[1], Count, BytesTrans, nil)
            and (Cardinal(Count) = BytesTrans);

     if not Result then Str := '';
     {if not Result then
       raise EComPort.Create(CError_ReadFailed, GetLastError);}
  end;
end;


// create handle to serial port
procedure TComPort.CreateHandle;
begin
  FHandle := CreateFile(
    PChar('\\.\' + FPort),
    GENERIC_READ or GENERIC_WRITE,
    0,
    nil,
    OPEN_EXISTING,
    0,
    0);

  if FHandle = INVALID_HANDLE_VALUE then
     raise EComPort.Create(CError_OpenFailed, GetLastError);
end;

// initialize port
procedure TComPort.SetupComPort;
begin
  ApplyBuffer;
  ApplyDCB;
  ApplyTimeouts;
end;
                                             
// destroy serial port handle
procedure TComPort.DestroyHandle;
begin
  if FHandle <> INVALID_HANDLE_VALUE then
    CloseHandle(FHandle);
end;

// apply port properties
procedure TComPort.ApplyDCB;
  const
    CParityBits: array[TParityBits] of Integer =
      (NOPARITY, ODDPARITY, EVENPARITY, MARKPARITY, SPACEPARITY);
    CStopBits: array[TStopBits] of Integer =
      (ONESTOPBIT, ONE5STOPBITS, TWOSTOPBITS);
    CBaudRate: array[TBaudRate] of Integer =
      (0, 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);
    CDataBits: array[TDataBits] of Integer = (5, 6, 7, 8);
    
var
  DCB: TDCB;
begin
  // if not connected or inside BeginUpdate/EndUpdate block, do nothing
  if FConnected and (FUpdateCount = 0) and
    not ((csDesigning in FOwner.ComponentState) or (csLoading in FOwner.ComponentState)) then
  begin
    GetCommState(FHandle, DCB);
    //DCB.DCBlength := SizeOf(TDCB);
    DCB.XonLim := FBuffer.InputSize div 4;
    DCB.XoffLim := DCB.XonLim;
    DCB.Parity := CParityBits[FParity.Bits];
    DCB.StopBits := CStopBits[FStopBits];
    if FBaudRate <> brCustom then
      DCB.BaudRate := CBaudRate[FBaudRate]
    else
      DCB.BaudRate := FCustomBaudRate;
    DCB.ByteSize := CDataBits[FDataBits];

    if FParity.Check then
    begin
      DCB.Flags := DCB.Flags or dcb_Parity;
      if FParity.Replace then
      begin
        DCB.Flags := DCB.Flags or dcb_ErrorChar;
        DCB.ErrorChar := Char(FParity.ReplaceChar);
      end;
    end;

    // apply settings
    if not SetCommState(FHandle, DCB) then
      raise EComPort.Create(CError_SetStateFailed, GetLastError);
  end;
end;

// apply buffers
procedure TComPort.ApplyBuffer;
begin
  // if not connected or inside BeginUpdate/EndUpdate block, do nothing
  if FConnected and (FUpdateCount = 0) and
      not ((csDesigning in FOwner.ComponentState) or (csLoading in FOwner.ComponentState))
  then
    //apply settings
    if not SetupComm(FHandle, FBuffer.InputSize, FBuffer.OutputSize) then
      raise EComPort.Create(CError_SetupComFailed, GetLastError);
end;

// apply timeout properties
procedure TComPort.ApplyTimeouts;
var
  Timeouts: TCommTimeouts;

  function GetTOValue(const Value: Integer): DWORD;
  begin
    if Value = -1 then
      Result := MAXDWORD
    else
      Result := Value;
  end;

begin
  // if not connected or inside BeginUpdate/EndUpdate block, do nothing
  if FConnected and (FUpdateCount = 0) and
    not ((csDesigning in FOwner.ComponentState) or (csLoading in FOwner.ComponentState)) then
  begin
    Timeouts.ReadIntervalTimeout := GetTOValue(FTimeouts.ReadInterval);
    Timeouts.ReadTotalTimeoutMultiplier := GetTOValue(FTimeouts.ReadTotalMultiplier);
    Timeouts.ReadTotalTimeoutConstant := GetTOValue(FTimeouts.ReadTotalConstant);
    Timeouts.WriteTotalTimeoutMultiplier := GetTOValue(FTimeouts.WriteTotalMultiplier);
    Timeouts.WriteTotalTimeoutConstant := GetTOValue(FTimeouts.WriteTotalConstant);

    // apply settings
    if not SetCommTimeouts(FHandle, Timeouts) then
      raise EComPort.Create(CError_TimeoutsFailed, GetLastError);
  end;
end;

// copy properties to other class
procedure TComPort.AssignTo(Dest: TPersistent);
begin
  if Dest is TComPort then
  begin
    with TComPort(Dest) do
    begin
      FParity   := Self.Parity;
      FTimeouts := Self.Timeouts;
      FBuffer   := Self.FBuffer;
    end
  end
  else
    inherited AssignTo(Dest);
end;

// set baud rate
procedure TComPort.SetBaudRate(const Value: TBaudRate);
begin
  if Value <> FBaudRate then
  begin
    FBaudRate := Value;
    // if possible, apply settings
    ApplyDCB;
  end;
end;

// set custom baud rate
procedure TComPort.SetCustomBaudRate(const Value: Integer);
begin
  if Value <> FCustomBaudRate then
  begin
    FCustomBaudRate := Value;
    ApplyDCB;
  end;
end;

// set port
procedure TComPort.SetPort(const Value: TPort);
begin
  // 11.1.2001 Ch. Kaufmann; removed function ComString, because there can be com ports
  // with names other than COMn.
  if Value <> FPort then
  begin
    FPort := Value;
    if FConnected and not ((csDesigning in FOwner.ComponentState) or
      (csLoading in FOwner.ComponentState)) then
    begin
      Close;
      Open;
    end;
  end;
end;

// set stop bits
procedure TComPort.SetStopBits(const Value: TStopBits);
begin
  if Value <> FStopBits then
  begin
    FStopBits := Value;
    ApplyDCB;
  end;
end;

// set data bits
procedure TComPort.SetDataBits(const Value: TDataBits);
begin
  if Value <> FDataBits then
  begin
    FDataBits := Value;
    ApplyDCB;
  end;
end;

// set connected property, same as Open/Close methods
procedure TComPort.SetConnected(const Value: Boolean);
begin
  if not ((csDesigning in FOwner.ComponentState) or (csLoading in FOwner.ComponentState)) then
  begin
    if Value <> FConnected then
      if Value then