1 | unit UDiallingService;
|
---|
2 |
|
---|
3 | interface
|
---|
4 |
|
---|
5 | uses
|
---|
6 | Windows, Messages, SysUtils, Classes, Graphics, Controls, SvcMgr, Dialogs,
|
---|
7 | magrascon, magrasedt, ExtCtrls, UMainForm, magrasapi, DosCommand,
|
---|
8 | UTextFileStream, Registry;
|
---|
9 |
|
---|
10 | type
|
---|
11 | TVpnDiallingService = class(TService)
|
---|
12 | MagRasEdt1: TMagRasEdt;
|
---|
13 | MagRasCon1: TMagRasCon;
|
---|
14 | Timer1: TTimer;
|
---|
15 | Timer2: TTimer;
|
---|
16 | procedure ServiceExecute(Sender: TService);
|
---|
17 | procedure Timer1Timer(Sender: TObject);
|
---|
18 | procedure MagRasCon1StateChanged(Sender: TObject);
|
---|
19 | procedure ServiceStart(Sender: TService; var Started: Boolean);
|
---|
20 | procedure Timer2Timer(Sender: TObject);
|
---|
21 | procedure ServiceStop(Sender: TService; var Stopped: Boolean);
|
---|
22 | private
|
---|
23 | DialHandle: Cardinal;
|
---|
24 | function GetLogFileEnabled: Boolean;
|
---|
25 | procedure SetLogFileEnabled(const Value: Boolean);
|
---|
26 | function GetLogFileName: string;
|
---|
27 | procedure SetLogFileName(const Value: string);
|
---|
28 | function GetConnectionName: string;
|
---|
29 | procedure SetConnectionName(const Value: string);
|
---|
30 | function GetLogClearOnStart: Boolean;
|
---|
31 | procedure SetLogClearOnStart(const Value: Boolean);
|
---|
32 | function GetNetworkDomain: string;
|
---|
33 | function GetConditionNetworkDomain: string;
|
---|
34 | procedure SetConditionNetworkDomain(const Value: string);
|
---|
35 | public
|
---|
36 | LastState: Word;
|
---|
37 | procedure Dial;
|
---|
38 | procedure DialLog(Message: string);
|
---|
39 | function GetServiceController: TServiceController; override;
|
---|
40 | property LogFileEnabled: Boolean read GetLogFileEnabled
|
---|
41 | write SetLogFileEnabled;
|
---|
42 | property LogFileName: string read GetLogFileName
|
---|
43 | write SetLogFileName;
|
---|
44 | property ConnectionName: string read GetConnectionName
|
---|
45 | write SetConnectionName;
|
---|
46 | property LogClearOnStart: Boolean read GetLogClearOnStart
|
---|
47 | write SetLogClearOnStart;
|
---|
48 | property NetworkDomain: string read GetNetworkDomain;
|
---|
49 | property ConditionNetworkDomain: string read GetConditionNetworkDomain
|
---|
50 | write SetConditionNetworkDomain;
|
---|
51 | end;
|
---|
52 |
|
---|
53 | var
|
---|
54 | VpnDiallingService: TVpnDiallingService;
|
---|
55 |
|
---|
56 | implementation
|
---|
57 |
|
---|
58 | {$R *.DFM}
|
---|
59 |
|
---|
60 | procedure ServiceController(CtrlCode: DWord); stdcall;
|
---|
61 | begin
|
---|
62 | VpnDiallingService.Controller(CtrlCode);
|
---|
63 | end;
|
---|
64 |
|
---|
65 | function TVpnDiallingService.GetServiceController: TServiceController;
|
---|
66 | begin
|
---|
67 | Result := ServiceController;
|
---|
68 | end;
|
---|
69 |
|
---|
70 | procedure TVpnDiallingService.ServiceExecute(Sender: TService);
|
---|
71 | begin
|
---|
72 | try
|
---|
73 | while not Terminated do begin
|
---|
74 | Sleep(1000);
|
---|
75 | //DialLog('.');
|
---|
76 | ServiceThread.ProcessRequests(True);
|
---|
77 | end;
|
---|
78 | finally
|
---|
79 | end;
|
---|
80 | DialLog('Konec');
|
---|
81 | end;
|
---|
82 |
|
---|
83 | procedure TVpnDiallingService.DialLog(Message: string);
|
---|
84 | var
|
---|
85 | LogFile: TTextFileStream;
|
---|
86 | begin
|
---|
87 | if LogFileEnabled then begin
|
---|
88 | if FileExists(LogFileName) then LogFile := TTextFileStream.Create(LogFileName, fmOpenReadWrite)
|
---|
89 | else LogFile := TTextFileStream.Create(LogFileName, fmCreate);
|
---|
90 | try
|
---|
91 | LogFile.Seek(0, soFromEnd);
|
---|
92 | LogFile.WriteLn(Message);
|
---|
93 | finally
|
---|
94 | LogFile.Free;
|
---|
95 | end;
|
---|
96 | end;
|
---|
97 | end;
|
---|
98 |
|
---|
99 | procedure TVpnDiallingService.Dial;
|
---|
100 | var
|
---|
101 | I: Integer;
|
---|
102 | begin
|
---|
103 | Timer2.Enabled := True;
|
---|
104 |
|
---|
105 | if MagRasCon1.ConnectState = RASCS_Connected then
|
---|
106 | MagRasCon1.DisconnectEx(DialHandle, 0, 3000, False);
|
---|
107 |
|
---|
108 | DialLog('');
|
---|
109 | DialLog(DateTimeToStr(Now) + ': Vytáèím pøípojení');
|
---|
110 | with MagRasCon1 do begin
|
---|
111 | GetConnections;
|
---|
112 | I := 0;
|
---|
113 | while (I < Connections.Count) and (Connections.EntryName(I) <> ConnectionName) do I := I + 1;
|
---|
114 | if not (I < Connections.Count) then begin
|
---|
115 | EntryName := ConnectionName;
|
---|
116 | PhoneNumber := '';
|
---|
117 | DialHandle := 0;
|
---|
118 | if AutoConnectEx(DialHandle) <> 0 then
|
---|
119 | DialLog('Dialling Failed - ' + MagRasCon1.StatusStr);
|
---|
120 | end;
|
---|
121 | end;
|
---|
122 | end;
|
---|
123 |
|
---|
124 | procedure TVpnDiallingService.Timer1Timer(Sender: TObject);
|
---|
125 | begin
|
---|
126 | if MagRasCon1.ConnectState <> RASCS_Connected then begin
|
---|
127 | Timer1.Enabled := False;
|
---|
128 | Dial;
|
---|
129 | end;
|
---|
130 | end;
|
---|
131 |
|
---|
132 | function TVpnDiallingService.GetConnectionName: string;
|
---|
133 | begin
|
---|
134 | with TRegistry.Create do
|
---|
135 | try
|
---|
136 | RootKey := HKEY_LOCAL_MACHINE;
|
---|
137 | OpenKey(RegistryPath, True);
|
---|
138 | if ValueExists('ConnectionName') then Result := ReadString('ConnectionName')
|
---|
139 | else Result := '';
|
---|
140 | finally
|
---|
141 | Free;
|
---|
142 | end;
|
---|
143 | end;
|
---|
144 |
|
---|
145 | procedure TVpnDiallingService.SetConnectionName(const Value: string);
|
---|
146 | begin
|
---|
147 | with TRegistry.Create do
|
---|
148 | try
|
---|
149 | RootKey := HKEY_LOCAL_MACHINE;
|
---|
150 | OpenKey(RegistryPath, True);
|
---|
151 | WriteString('ConnectionName', Value)
|
---|
152 | finally
|
---|
153 | Free;
|
---|
154 | end;
|
---|
155 | end;
|
---|
156 |
|
---|
157 | function TVpnDiallingService.GetLogFileEnabled: Boolean;
|
---|
158 | begin
|
---|
159 | with TRegistry.Create do
|
---|
160 | try
|
---|
161 | RootKey := HKEY_LOCAL_MACHINE;
|
---|
162 | OpenKey(RegistryPath, True);
|
---|
163 | if ValueExists('LogFileEnabled') then Result := ReadBool('LogFileEnabled')
|
---|
164 | else Result := False;
|
---|
165 | finally
|
---|
166 | Free;
|
---|
167 | end;
|
---|
168 | end;
|
---|
169 |
|
---|
170 | procedure TVpnDiallingService.SetLogFileEnabled(const Value: Boolean);
|
---|
171 | begin
|
---|
172 | with TRegistry.Create do
|
---|
173 | try
|
---|
174 | RootKey := HKEY_LOCAL_MACHINE;
|
---|
175 | OpenKey(RegistryPath, True);
|
---|
176 | WriteBool('LogFileEnabled', Value)
|
---|
177 | finally
|
---|
178 | Free;
|
---|
179 | end;
|
---|
180 | end;
|
---|
181 |
|
---|
182 | function TVpnDiallingService.GetLogFileName: string;
|
---|
183 | begin
|
---|
184 | with TRegistry.Create do
|
---|
185 | try
|
---|
186 | RootKey := HKEY_LOCAL_MACHINE;
|
---|
187 | OpenKey(RegistryPath, True);
|
---|
188 | if ValueExists('LogFileName') then Result := ReadString('LogFileName')
|
---|
189 | else Result := ApplicationDataFolder + '\' + DefaultLogFileName;
|
---|
190 | finally
|
---|
191 | Free;
|
---|
192 | end;
|
---|
193 | end;
|
---|
194 |
|
---|
195 | procedure TVpnDiallingService.SetLogFileName(const Value: string);
|
---|
196 | begin
|
---|
197 | with TRegistry.Create do
|
---|
198 | try
|
---|
199 | RootKey := HKEY_LOCAL_MACHINE;
|
---|
200 | OpenKey(RegistryPath, True);
|
---|
201 | WriteString('LogFileName', Value)
|
---|
202 | finally
|
---|
203 | Free;
|
---|
204 | end;
|
---|
205 | end;
|
---|
206 |
|
---|
207 | procedure TVpnDiallingService.MagRasCon1StateChanged(Sender: TObject);
|
---|
208 | var
|
---|
209 | Info: string;
|
---|
210 | begin
|
---|
211 | if LastState = MagRasCon1.ConnectState then Exit;
|
---|
212 |
|
---|
213 | // check type of event
|
---|
214 | Info := '';
|
---|
215 | case MagRasCon1.StateEventSource of
|
---|
216 | SourceDial: Info := ' Dial: ';
|
---|
217 | SourceStatus: begin
|
---|
218 | Info := ' Status: ';
|
---|
219 | Timer1.Enabled := True;
|
---|
220 | end;
|
---|
221 | SourceHangup: Info := ' Hangup: ';
|
---|
222 | end;
|
---|
223 |
|
---|
224 | // see if new event, else display it
|
---|
225 | LastState := MagRasCon1.ConnectState ;
|
---|
226 | DialLog(Info + MagRasCon1.StatusStr
|
---|
227 | + ' (' + IntToStr(LastState) + ')');
|
---|
228 |
|
---|
229 | // if dialling need to see what's happened
|
---|
230 | if DialHandle <> 0 then begin
|
---|
231 | // online OK, restart timer
|
---|
232 | if (MagRasCon1.ConnectState = RASCS_Connected) then begin
|
---|
233 | // ConnHandle := DialHandle
|
---|
234 | // DialHandle := 0;
|
---|
235 | // TimerStatus.Enabled := True;
|
---|
236 | end;
|
---|
237 |
|
---|
238 | // dialling failed, either an error or disconnected
|
---|
239 | if ((MagRasCon1.ConnectState > RASBase) and
|
---|
240 | (MagRasCon1.ConnectState < RASCS_Paused)) or
|
---|
241 | (MagRasCon1.ConnectState = RASCS_Disconnected) then begin
|
---|
242 | // disconnect, returns when done or after three seconds, no StateChanged
|
---|
243 | //ConnHandle := DialHandle;
|
---|
244 | //DialHandle := 0;
|
---|
245 | MagRasCon1.DisconnectEx(DialHandle, 0, 3000, False);
|
---|
246 | Timer1.Enabled := True;
|
---|
247 | // reset is done in timer event
|
---|
248 | end;
|
---|
249 | end;
|
---|
250 | end;
|
---|
251 |
|
---|
252 | procedure TVpnDiallingService.ServiceStart(Sender: TService; var Started: Boolean);
|
---|
253 | begin
|
---|
254 | if LogClearOnStart and FileExists(LogFileName) then DeleteFile(LogFileName);
|
---|
255 | DialLog('Sluba sputìna v ' + DateTimeToStr(Now));
|
---|
256 | DialLog('Síová DNS pøípona: ' + NetworkDomain);
|
---|
257 | if NetworkDomain = ConditionNetworkDomain then
|
---|
258 | Timer1.Enabled := True;
|
---|
259 | end;
|
---|
260 |
|
---|
261 | procedure TVpnDiallingService.Timer2Timer(Sender: TObject);
|
---|
262 | begin
|
---|
263 | MagRasCon1.CurrentStatusEx(DialHandle, 0);
|
---|
264 | end;
|
---|
265 |
|
---|
266 | function TVpnDiallingService.GetLogClearOnStart: Boolean;
|
---|
267 | begin
|
---|
268 | with TRegistry.Create do
|
---|
269 | try
|
---|
270 | RootKey := HKEY_LOCAL_MACHINE;
|
---|
271 | OpenKey(RegistryPath, True);
|
---|
272 | if ValueExists('LogClearOnStart') then Result := ReadBool('LogClearOnStart')
|
---|
273 | else Result := False;
|
---|
274 | finally
|
---|
275 | Free;
|
---|
276 | end;
|
---|
277 | end;
|
---|
278 |
|
---|
279 | procedure TVpnDiallingService.SetLogClearOnStart(const Value: Boolean);
|
---|
280 | begin
|
---|
281 | with TRegistry.Create do
|
---|
282 | try
|
---|
283 | RootKey := HKEY_LOCAL_MACHINE;
|
---|
284 | OpenKey(RegistryPath, True);
|
---|
285 | WriteBool('LogClearOnStart', Value)
|
---|
286 | finally
|
---|
287 | Free;
|
---|
288 | end;
|
---|
289 | end;
|
---|
290 |
|
---|
291 | procedure TVpnDiallingService.ServiceStop(Sender: TService; var Stopped: Boolean);
|
---|
292 | begin
|
---|
293 | Timer1.Enabled := False;
|
---|
294 | Timer2.Enabled := False;
|
---|
295 | MagRasCon1.DisconnectEx(DialHandle, 0, 3000, False);
|
---|
296 |
|
---|
297 | DialLog('Sluba zastavena v ' + DateTimeToStr(Now));
|
---|
298 | end;
|
---|
299 |
|
---|
300 | function TVpnDiallingService.GetNetworkDomain: string;
|
---|
301 | var
|
---|
302 | Command: TDosCommand;
|
---|
303 | I: Integer;
|
---|
304 | Lines2: TStringList;
|
---|
305 | begin
|
---|
306 | Lines2 := TStringList.Create;
|
---|
307 | Result := '';
|
---|
308 | Command := TDosCommand.Create(nil);
|
---|
309 | with Command do try
|
---|
310 | CommandLine := 'ipconfig /all';
|
---|
311 | OutputLines := Lines2;
|
---|
312 | Execute2;
|
---|
313 | for I := 0 to Lines2.Count - 1 do
|
---|
314 | if Pos('Prohledávací seznam pøípon DNS', Lines2[I]) > 0 then
|
---|
315 | Result := Copy(Lines2[I], Pos(':', Lines2[I]) + 2, 255);
|
---|
316 | finally
|
---|
317 | Free;
|
---|
318 | Lines2.Free;
|
---|
319 | end;
|
---|
320 | end;
|
---|
321 |
|
---|
322 | function TVpnDiallingService.GetConditionNetworkDomain: string;
|
---|
323 | begin
|
---|
324 | with TRegistry.Create do
|
---|
325 | try
|
---|
326 | RootKey := HKEY_LOCAL_MACHINE;
|
---|
327 | OpenKey(RegistryPath, True);
|
---|
328 | if ValueExists('ConditionNetworkDomain') then Result := ReadString('ConditionNetworkDomain')
|
---|
329 | else Result := 'zdechov.net';
|
---|
330 | finally
|
---|
331 | Free;
|
---|
332 | end;
|
---|
333 | end;
|
---|
334 |
|
---|
335 | procedure TVpnDiallingService.SetConditionNetworkDomain(
|
---|
336 | const Value: string);
|
---|
337 | begin
|
---|
338 | with TRegistry.Create do
|
---|
339 | try
|
---|
340 | RootKey := HKEY_LOCAL_MACHINE;
|
---|
341 | OpenKey(RegistryPath, True);
|
---|
342 | WriteString('ConditionNetworkDomain', Value);
|
---|
343 | finally
|
---|
344 | Free;
|
---|
345 | end;
|
---|
346 | end;
|
---|
347 |
|
---|
348 | end.
|
---|