source: trunk/UDiallingService.pas

unit UDiallingService;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, SvcMgr, Dialogs,
  magrascon, magrasedt, ExtCtrls, UMainForm, magrasapi, DosCommand,
  UTextFileStream, Registry;

type
  TVpnDiallingService = class(TService)
    MagRasEdt1: TMagRasEdt;
    MagRasCon1: TMagRasCon;
    Timer1: TTimer;
    Timer2: TTimer;
    procedure ServiceExecute(Sender: TService);
    procedure Timer1Timer(Sender: TObject);
    procedure MagRasCon1StateChanged(Sender: TObject);
    procedure ServiceStart(Sender: TService; var Started: Boolean);
    procedure Timer2Timer(Sender: TObject);
    procedure ServiceStop(Sender: TService; var Stopped: Boolean);
  private
    DialHandle: Cardinal;
    function GetLogFileEnabled: Boolean;
    procedure SetLogFileEnabled(const Value: Boolean);
    function GetLogFileName: string;
    procedure SetLogFileName(const Value: string);
    function GetConnectionName: string;
    procedure SetConnectionName(const Value: string);
    function GetLogClearOnStart: Boolean;
    procedure SetLogClearOnStart(const Value: Boolean);
    function GetNetworkDomain: string;
    function GetConditionNetworkDomain: string;
    procedure SetConditionNetworkDomain(const Value: string);
  public
    LastState: Word;
    procedure Dial;
    procedure DialLog(Message: string);
    function GetServiceController: TServiceController; override;
    property LogFileEnabled: Boolean read GetLogFileEnabled
      write SetLogFileEnabled;
    property LogFileName: string read GetLogFileName
      write SetLogFileName;
    property ConnectionName: string read GetConnectionName
      write SetConnectionName;
    property LogClearOnStart: Boolean read GetLogClearOnStart
      write SetLogClearOnStart;
    property NetworkDomain: string read GetNetworkDomain;
    property ConditionNetworkDomain: string read GetConditionNetworkDomain
      write SetConditionNetworkDomain;
  end;

var
  VpnDiallingService: TVpnDiallingService;

implementation

{$R *.DFM}

procedure ServiceController(CtrlCode: DWord); stdcall;
begin
  VpnDiallingService.Controller(CtrlCode);
end;

function TVpnDiallingService.GetServiceController: TServiceController;
begin
  Result := ServiceController;
end;

procedure TVpnDiallingService.ServiceExecute(Sender: TService);
begin
  try
    while not Terminated do begin
      Sleep(1000);
      //DialLog('.');
      ServiceThread.ProcessRequests(True);
    end;
  finally
  end;
  DialLog('Konec');
end;

procedure TVpnDiallingService.DialLog(Message: string);
var
  LogFile: TTextFileStream;
begin
  if LogFileEnabled then begin
    if FileExists(LogFileName) then LogFile := TTextFileStream.Create(LogFileName, fmOpenReadWrite)
      else LogFile := TTextFileStream.Create(LogFileName, fmCreate);
    try
      LogFile.Seek(0, soFromEnd);
      LogFile.WriteLn(Message);
    finally
      LogFile.Free;
    end;
  end;
end;

procedure TVpnDiallingService.Dial;
var
  I: Integer;
begin
  Timer2.Enabled := True;

    if MagRasCon1.ConnectState = RASCS_Connected then
      MagRasCon1.DisconnectEx(DialHandle, 0, 3000, False);

    DialLog('');
    DialLog(DateTimeToStr(Now) + ': Vytáèím pøípojení');
        with MagRasCon1 do begin
      GetConnections;
      I := 0;
      while (I < Connections.Count) and (Connections.EntryName(I) <> ConnectionName) do I := I + 1;
      if not (I < Connections.Count) then begin
        EntryName := ConnectionName;
              PhoneNumber :=    '';
            DialHandle := 0;
        if AutoConnectEx(DialHandle) <> 0 then
          DialLog('Dialling Failed - ' + MagRasCon1.StatusStr);
      end;
    end;
end;

procedure TVpnDiallingService.Timer1Timer(Sender: TObject);
begin
  if MagRasCon1.ConnectState <> RASCS_Connected then begin
    Timer1.Enabled := False;
    Dial;
  end;
end;

function TVpnDiallingService.GetConnectionName: string;
begin
  with TRegistry.Create do
  try
    RootKey := HKEY_LOCAL_MACHINE;
    OpenKey(RegistryPath, True);
      if ValueExists('ConnectionName') then Result := ReadString('ConnectionName')
        else Result := '';
  finally
    Free;
  end;
end;

procedure TVpnDiallingService.SetConnectionName(const Value: string);
begin
  with TRegistry.Create do
  try
    RootKey := HKEY_LOCAL_MACHINE;
    OpenKey(RegistryPath, True);
    WriteString('ConnectionName', Value)
  finally
    Free;
  end;
end;

function TVpnDiallingService.GetLogFileEnabled: Boolean;
begin
  with TRegistry.Create do
  try
    RootKey := HKEY_LOCAL_MACHINE;
    OpenKey(RegistryPath, True);
      if ValueExists('LogFileEnabled') then Result := ReadBool('LogFileEnabled')
        else Result := False;
  finally
    Free;
  end;
end;

procedure TVpnDiallingService.SetLogFileEnabled(const Value: Boolean);
begin
  with TRegistry.Create do
  try
    RootKey := HKEY_LOCAL_MACHINE;
    OpenKey(RegistryPath, True);
    WriteBool('LogFileEnabled', Value)
  finally
    Free;
  end;
end;

function TVpnDiallingService.GetLogFileName: string;
begin
  with TRegistry.Create do
  try
    RootKey := HKEY_LOCAL_MACHINE;
    OpenKey(RegistryPath, True);
    if ValueExists('LogFileName') then Result := ReadString('LogFileName')
      else Result := ApplicationDataFolder + '\' + DefaultLogFileName;
  finally
    Free;
  end;
end;

procedure TVpnDiallingService.SetLogFileName(const Value: string);
begin
  with TRegistry.Create do
  try
    RootKey := HKEY_LOCAL_MACHINE;
    OpenKey(RegistryPath, True);
    WriteString('LogFileName', Value)
  finally
    Free;
  end;
end;

procedure TVpnDiallingService.MagRasCon1StateChanged(Sender: TObject);
var
        Info: string;
begin
        if LastState = MagRasCon1.ConnectState then Exit;

  // check type of event
        Info := '';
  case MagRasCon1.StateEventSource of
        SourceDial: Info := ' Dial: ';
        SourceStatus: begin
      Info := ' Status: ';
      Timer1.Enabled := True;
    end;
        SourceHangup: Info := ' Hangup: ';
        end;

  // see if new event, else display it
  LastState := MagRasCon1.ConnectState ;
  DialLog(Info + MagRasCon1.StatusStr
    +   ' (' + IntToStr(LastState) + ')');

  // if dialling need to see what's happened
        if DialHandle <> 0 then begin
        // online OK, restart timer
                if (MagRasCon1.ConnectState = RASCS_Connected) then begin
//      ConnHandle := DialHandle
//      DialHandle := 0;
//      TimerStatus.Enabled := True;
                end;

          // dialling failed, either an error or disconnected
                if ((MagRasCon1.ConnectState > RASBase) and
            (MagRasCon1.ConnectState < RASCS_Paused)) or
            (MagRasCon1.ConnectState = RASCS_Disconnected) then begin
        // disconnect, returns when done or after three seconds, no StateChanged
        //ConnHandle := DialHandle;
                          //DialHandle := 0;
                        MagRasCon1.DisconnectEx(DialHandle, 0, 3000, False);
        Timer1.Enabled := True;
        // reset is done in timer event
                  end;
        end;
end;

procedure TVpnDiallingService.ServiceStart(Sender: TService; var Started: Boolean);
begin
  if LogClearOnStart and FileExists(LogFileName) then DeleteFile(LogFileName);
  DialLog('Služba spuštìna v ' + DateTimeToStr(Now));
  DialLog('Síová DNS pøípona: ' + NetworkDomain);
  if NetworkDomain = ConditionNetworkDomain then
    Timer1.Enabled := True;
end;

procedure TVpnDiallingService.Timer2Timer(Sender: TObject);
begin
  MagRasCon1.CurrentStatusEx(DialHandle, 0);
end;

function TVpnDiallingService.GetLogClearOnStart: Boolean;
begin
  with TRegistry.Create do
  try
    RootKey := HKEY_LOCAL_MACHINE;
    OpenKey(RegistryPath, True);
    if ValueExists('LogClearOnStart') then Result := ReadBool('LogClearOnStart')
      else Result := False;
  finally
    Free;
  end;
end;

procedure TVpnDiallingService.SetLogClearOnStart(const Value: Boolean);
begin
  with TRegistry.Create do
  try
    RootKey := HKEY_LOCAL_MACHINE;
    OpenKey(RegistryPath, True);
    WriteBool('LogClearOnStart', Value)
  finally
    Free;
  end;
end;

procedure TVpnDiallingService.ServiceStop(Sender: TService; var Stopped: Boolean);
begin
  Timer1.Enabled := False;
  Timer2.Enabled := False;
        MagRasCon1.DisconnectEx(DialHandle, 0, 3000, False);

  DialLog('Služba zastavena v ' + DateTimeToStr(Now));
end;

function TVpnDiallingService.GetNetworkDomain: string;
var
  Command: TDosCommand;
  I: Integer;
  Lines2: TStringList;
begin
  Lines2 := TStringList.Create;
  Result := '';
  Command := TDosCommand.Create(nil);
  with Command do try
    CommandLine := 'ipconfig /all';
    OutputLines := Lines2;
    Execute2;
    for I := 0 to Lines2.Count - 1 do
      if Pos('Prohledávací seznam pøípon DNS', Lines2[I]) > 0 then
        Result := Copy(Lines2[I], Pos(':', Lines2[I]) + 2, 255);
  finally
    Free;
    Lines2.Free;
  end;
end;

function TVpnDiallingService.GetConditionNetworkDomain: string;
begin
  with TRegistry.Create do
  try
    RootKey := HKEY_LOCAL_MACHINE;
    OpenKey(RegistryPath, True);
    if ValueExists('ConditionNetworkDomain') then Result := ReadString('ConditionNetworkDomain')
      else Result := 'zdechov.net';
  finally
    Free;
  end;
end;

procedure TVpnDiallingService.SetConditionNetworkDomain(
  const Value: string);
begin
  with TRegistry.Create do
  try
    RootKey := HKEY_LOCAL_MACHINE;
    OpenKey(RegistryPath, True);
    WriteString('ConditionNetworkDomain', Value);
  finally
    Free;
  end;
end;

end.