source: trunk/UMainForm.pas

Last change on this file was 5, checked in by george, 15 years ago
  • Odstraněno: Funkce a ovládací prvky související s vytáčením VPN.
File size: 14.9 KB
Line 
1unit UMainForm;
2
3interface
4
5uses
6 Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
7 Dialogs, StdCtrls, ComCtrls, ShellApi, DosCommand, Registry, Menus,
8 CoolTrayIcon, ExtCtrls, XPMan, SHFolder,
9 ShlObj, Winsock, UTextFileStream;
10
11const
12 ApplicationName = 'Konfigurátor ZdìchovNET';
13 Author = 'Jiøí Hajda';
14 HomePage = 'http://www.zdechov.net/';
15 Email = 'robie@centrum.cz';
16 Version = '1.3';
17 ReleaseDate = '4.9.2006';
18 Creator = 'Chronosoft';
19 RegistryRootKey = HKEY_LOCAL_MACHINE;
20 RegistryPath = '\Software\'+Creator+'\Configurator ZdechovNET';
21 ChangeLogFile = 'Novinky.txt';
22 Licence = 'Copyleft';
23
24 DefaultLogFileName = 'DialLog.txt';
25 DiallingServiceName = 'VpnDiallingService';
26 DiallingServiceDisplayName = 'VPN Dialling service';
27
28 BrowserHomepage = 'http://centrala.zdechov.net/';
29 WorkGroup = 'ZDECHOV';
30 DefaultConnectionName = 'ZdìchovNET';
31 ConnectionHost = 'centrala.zdechov.net';
32 MainSharedFolderPath = 'C:\Net';
33 MainSharedFolderName = 'Net';
34 LocalNetAddr = '192.168.0.0';
35 LocalNetMask = '255.255.0.0';
36
37type
38 TMainForm = class(TForm)
39 Button1: TButton;
40 Button2: TButton;
41 Bevel1: TBevel;
42 CheckBox4: TCheckBox;
43 CoolTrayIcon1: TCoolTrayIcon;
44 Button3: TButton;
45 PopupMenu1: TPopupMenu;
46 Ukonit1: TMenuItem;
47 estst1: TMenuItem;
48 Nastaven1: TMenuItem;
49 CheckBox5: TCheckBox;
50 XPManifest1: TXPManifest;
51 CheckBox6: TCheckBox;
52 Oprogramu1: TMenuItem;
53 CheckBox9: TCheckBox;
54 Zznamvyten1: TMenuItem;
55 OpenDialog1: TOpenDialog;
56 VPNpipojen1: TMenuItem;
57 Spustit1: TMenuItem;
58 Zasavit1: TMenuItem;
59 procedure FormShow(Sender: TObject);
60 procedure Button2Click(Sender: TObject);
61 procedure Button1Click(Sender: TObject);
62 procedure estst1Click(Sender: TObject);
63 procedure Ukonit1Click(Sender: TObject);
64 procedure FormCreate(Sender: TObject);
65 procedure Nastaven1Click(Sender: TObject);
66 procedure FormDestroy(Sender: TObject);
67 procedure Button3Click(Sender: TObject);
68 procedure Oprogramu1Click(Sender: TObject);
69 private
70 procedure LoadOptions;
71 procedure SaveOptions;
72 function GetCentralaHomepage: Boolean;
73 procedure SetCentralaHomepage(const Value: Boolean);
74 function GetWorkgroupZdechov: Boolean;
75 procedure SetWorkgroupZdechov(const Value: Boolean);
76 function GetRunOnSystemStart: Boolean;
77 procedure SetRunOnSystemStart(const Value: Boolean);
78 function GetShareUnblockFirewall: Boolean;
79 procedure SetShareUnblockFirewall(const Value: Boolean);
80 function GetNetSharedFolder: Boolean;
81 procedure SetNetSharedFolder(const Value: Boolean);
82 function GetNetworkDomain: string;
83 public
84 FirstStart: Boolean;
85 HostFilterIndex: Integer;
86 PingTimeout: Integer;
87 NetworkTestLastUpdate: TDateTime;
88 property CentralaHomepage: Boolean read GetCentralaHomepage
89 write SetCentralaHomepage;
90 property WorkgroupZdechov: Boolean read GetWorkgroupZdechov
91 write SetWorkgroupZdechov;
92 property RunOnSystemStart: Boolean read GetRunOnSystemStart
93 write SetRunOnSystemStart;
94 property ShareUnblockFirewall: Boolean read GetShareUnblockFirewall
95 write SetShareUnblockFirewall;
96 property NetSharedFolder: Boolean read GetNetSharedFolder
97 write SetNetSharedFolder;
98 property NetworkDomain: string read GetNetworkDomain;
99
100 procedure Init;
101 end;
102
103var
104 MainForm: TMainForm;
105
106function ApplicationDataFolder: string;
107function GetIPFromHost(var HostName, IPaddr, WSAErr: string): Boolean;
108function GetComputerNetName: string;
109function CommonAppDataPath: string;
110procedure ShellLaunch(const S: String);
111
112implementation
113
114uses UNetworkTest, UAboutWindow, ULogExceptions, DateUtils, Math,
115 StrUtils, UServiceControl;
116
117{$R *.dfm}
118
119const
120
121 // Share types
122 STYPE_ALL = -1; //note: my const
123 STYPE_DISKTREE = 0;
124 STYPE_PRINTQ = 1;
125 STYPE_DEVICE = 2;
126 STYPE_IPC = 3;
127 STYPE_SPECIAL = $80000000;
128
129 // Share permission
130 ACCESS_READ = 1;
131 ACCESS_WRITE = 2;
132 ACCESS_CREATE = 4;
133 ACCESS_EXEC = 8;
134 ACCESS_DELETE = 16;
135 ACCESS_ATRIB = 32;
136 ACCESS_PERM = 64;
137 ACCESS_ALL = ACCESS_READ or ACCESS_WRITE or ACCESS_CREATE or ACCESS_EXEC or
138 ACCESS_DELETE or ACCESS_ATRIB or ACCESS_PERM;
139
140type
141 TShareInfo2 = record
142 shi2_netname : PWideChar;
143 shi2_type : DWORD;
144 shi2_remark : PWideChar;
145 shi2_permissions : DWORD;
146 shi2_max_uses : DWORD;
147 shi2_current_uses : DWORD;
148 shi2_path : PWideChar;
149 shi2_passwd : PWideChar;
150 end;
151 PShareInfo2 = ^TShareInfo2;
152
153procedure NetApiBufferFree(Buf: Pointer) stdcall; external 'netapi32.dll';
154function NetShareGetInfo(SeverName, NetName: PWideChar; Level: DWORD;
155 Buf: Pointer): LongInt; stdcall; external 'netapi32.dll';
156function NetShareDel(ServerName, ShareName : PWideChar; Reserved: DWord):
157 LongInt; stdcall; external 'netapi32.dll';
158function NetShareAdd(ServerName : PWideChar; Level : DWord;
159 Buffer : Pointer; var ParamError :DWord) : Longint; stdcall; external 'netapi32.dll';
160
161
162function CommonAppDataPath: string;
163const
164 SHGFP_TYPE_CURRENT = 0;
165 MAXPATH = 255;
166var
167 Path: array [0..MAXPATH] of Char;
168begin
169 SHGetFolderPath(0, CSIDL_COMMON_APPDATA, 0, SHGFP_TYPE_CURRENT, @Path[0]);
170 Result := Path;
171end;
172
173function ApplicationDataFolder: string;
174begin
175 Result := CommonAppDataPath + '\' + Creator + '\' + ApplicationName;
176 if not DirectoryExists(Result) then
177 ForceDirectories(Result);
178end;
179
180procedure ShellLaunch(const S: String);
181begin
182 ShellExecute(0, 'open', PChar(S), '', '', SW_SHOWNORMAL);
183end;
184
185function GetComputerNetName: string;
186var
187 buffer: array[0..255] of char;
188 size: dword;
189begin
190 size := 256;
191 if GetComputerName(buffer, size) then
192 Result := buffer
193 else
194 Result := ''
195end;
196
197function TMainForm.GetCentralaHomepage: Boolean;
198begin
199 with TRegistry.Create do
200 try
201 RootKey := HKEY_CURRENT_USER;
202 OpenKey('\Software\Microsoft\Internet Explorer\Main', True);
203 Result := ReadString('Start Page') = BrowserHomepage;
204 finally
205 Free;
206 end;
207end;
208
209procedure TMainForm.SetCentralaHomepage(const Value: Boolean);
210begin
211 with TRegistry.Create do
212 try
213 RootKey := HKEY_CURRENT_USER;
214 OpenKey('\Software\Microsoft\Internet Explorer\Main', True);
215 if Value then begin
216 WriteString('LastStartPage', ReadString('Start Page'));
217 WriteString('Start Page', BrowserHomepage);
218 end else WriteString('Start Page', ReadString('LastStartPage'));
219 finally
220 Free;
221 end;
222end;
223
224procedure TMainForm.FormShow(Sender: TObject);
225begin
226 LogExceptions.NazevAplikace := ApplicationName + ' ' + Version;
227
228 CheckBox4.Checked := CentralaHomepage;
229 CheckBox5.Checked := WorkgroupZdechov;
230 CheckBox6.Checked := ShareUnblockFirewall;
231 CheckBox9.Checked := NetSharedFolder;
232end;
233
234procedure TMainForm.Button2Click(Sender: TObject);
235begin
236 CoolTrayIcon1.HideMainForm;
237end;
238
239procedure TMainForm.Button1Click(Sender: TObject);
240begin
241 CentralaHomepage := CheckBox4.Checked;
242 WorkgroupZdechov := CheckBox5.Checked;
243 ShareUnblockFirewall := CheckBox6.Checked;
244 NetSharedFolder := CheckBox9.Checked;
245
246 CoolTrayIcon1.HideMainForm;
247 SaveOptions;
248end;
249
250function TMainForm.GetWorkgroupZdechov: Boolean;
251var
252 Command: TDosCommand;
253 I: Integer;
254 Lines2: TStringList;
255begin
256 Lines2 := TStringList.Create;
257 Result := False;
258 Command := TDosCommand.Create(nil);
259 with Command do try
260 CommandLine := ExtractFilePath(Application.ExeName)+'netdom member \\'+GetComputerNetName+' /query';
261 OutputLines := Lines2;
262 Execute2;
263 for I := 0 to Lines2.Count - 1 do
264 if Pos(' ' + Workgroup + '.', Lines2[I]) > 0 then Result := True;
265 finally
266 Free;
267 Lines2.Free;
268 end;
269end;
270
271procedure TMainForm.SetWorkgroupZdechov(const Value: Boolean);
272var
273 Command: TDosCommand;
274begin
275 Command := TDosCommand.Create(nil);
276 with Command do try
277 if Value then CommandLine := 'netdom member \\'+GetComputerNetName+' /joinworkgroup '+WorkGroup;
278 Execute2;
279 finally
280 Free;
281 end;
282end;
283
284procedure TMainForm.estst1Click(Sender: TObject);
285begin
286 NetworkTest.Show;
287end;
288
289procedure TMainForm.Ukonit1Click(Sender: TObject);
290begin
291 Close;
292end;
293
294function TMainForm.GetRunOnSystemStart: Boolean;
295begin
296 with TRegistry.Create do
297 try
298 RootKey := HKEY_LOCAL_MACHINE;
299 OpenKey('\Software\Microsoft\Windows\CurrentVersion\Run', True);
300 Result := ReadString(ApplicationName) = Application.ExeName;
301 finally
302 Free;
303 end;
304end;
305
306procedure TMainForm.SetRunOnSystemStart(const Value: Boolean);
307begin
308 with TRegistry.Create do
309 try
310 RootKey := HKEY_LOCAL_MACHINE;
311 OpenKey('\Software\Microsoft\Windows\CurrentVersion\Run', True);
312 if Value then WriteString(ApplicationName, Application.ExeName)
313 else DeleteValue(ApplicationName);
314 finally
315 Free;
316 end;
317end;
318
319procedure TMainForm.FormCreate(Sender: TObject);
320begin
321// Connecting := False;
322 with CoolTrayIcon1 do begin
323 HideTaskbarIcon;
324 Hint := ApplicationName;
325 end;
326
327 LoadOptions;
328 Application.ShowMainForm := not FirstStart;
329end;
330
331procedure TMainForm.Nastaven1Click(Sender: TObject);
332begin
333 CoolTrayIcon1.ShowMainForm;
334end;
335
336function TMainForm.GetShareUnblockFirewall: Boolean;
337begin
338 with TRegistry.Create do
339 try
340 RootKey := HKEY_LOCAL_MACHINE;
341 OpenKey('\SYSTEM\CurrentControlSet\Services\SharedAccess\Parameters\FirewallPolicy\StandardProfile\GloballyOpenPorts\List', True);
342 Result := (ReadString('137:UDP') = '137:UDP:'+LocalNetAddr+'/'+LocalNetMask+':Enabled:@xpsp2res.dll,-22001')
343 and (ReadString('138:UDP') = '138:UDP:'+LocalNetAddr+'/'+LocalNetMask+':Enabled:@xpsp2res.dll,-22002')
344 and (ReadString('139:TCP') = '139:TCP:'+LocalNetAddr+'/'+LocalNetMask+':Enabled:@xpsp2res.dll,-22004')
345 and (ReadString('445:TCP') = '445:TCP:'+LocalNetAddr+'/'+LocalNetMask+':Enabled:@xpsp2res.dll,-22005');
346 finally
347 Free;
348 end;
349end;
350
351procedure TMainForm.SetShareUnblockFirewall(const Value: Boolean);
352begin
353 with TRegistry.Create do
354 try
355 RootKey := HKEY_LOCAL_MACHINE;
356 OpenKey('\SYSTEM\CurrentControlSet\Services\SharedAccess\Parameters\FirewallPolicy\StandardProfile\GloballyOpenPorts\List', True);
357 if Value then begin
358 WriteString('137:UDP', '137:UDP:'+LocalNetAddr+'/'+LocalNetMask+':Enabled:@xpsp2res.dll,-22001');
359 WriteString('138:UDP', '138:UDP:'+LocalNetAddr+'/'+LocalNetMask+':Enabled:@xpsp2res.dll,-22002');
360 WriteString('139:TCP', '139:TCP:'+LocalNetAddr+'/'+LocalNetMask+':Enabled:@xpsp2res.dll,-22004');
361 WriteString('445:TCP', '445:TCP:'+LocalNetAddr+'/'+LocalNetMask+':Enabled:@xpsp2res.dll,-22005');
362 end else begin
363 WriteString('137:UDP', '137:UDP:LocalSubNet:Enabled:@xpsp2res.dll,-22001');
364 WriteString('138:UDP', '138:UDP:LocalSubNet:Enabled:@xpsp2res.dll,-22002');
365 WriteString('139:TCP', '139:TCP:LocalSubNet:Enabled:@xpsp2res.dll,-22004');
366 WriteString('445:TCP', '445:TCP:LocalSubNet:Enabled:@xpsp2res.dll,-22005');
367 end;
368 finally
369 Free;
370 end;
371end;
372
373procedure TMainForm.FormDestroy(Sender: TObject);
374begin
375 SaveOptions;
376end;
377
378procedure TMainForm.Button3Click(Sender: TObject);
379begin
380 CheckBox4.Checked := True;
381 CheckBox5.Checked := True;
382 CheckBox6.Checked := True;
383 CheckBox9.Checked := True;
384end;
385
386procedure TMainForm.Oprogramu1Click(Sender: TObject);
387begin
388 AboutWindow.ShowModal;
389end;
390
391function TMainForm.GetNetSharedFolder: Boolean;
392var
393 PShareInfo: PShareInfo2;
394begin
395 Result := False;
396 NetShareGetInfo(nil, MainSharedFolderName, 2, @PShareInfo);
397 if Assigned(PShareInfo) then begin
398 Result := PShareInfo.shi2_path = MainSharedFolderPath;
399 NetApiBufferFree(PShareInfo);
400 end;
401end;
402
403procedure TMainForm.SetNetSharedFolder(const Value: Boolean);
404var
405 Err: Cardinal;
406 ShareInfo: TShareInfo2;
407begin
408 if Value then begin
409 if not DirectoryExists(MainSharedFolderPath) then ForceDirectories(MainSharedFolderPath);
410 with ShareInfo do begin
411 shi2_netname := MainSharedFolderName;
412 shi2_path := MainSharedFolderPath;
413 shi2_permissions := ACCESS_ALL;
414 shi2_remark := '';
415 shi2_type := STYPE_DISKTREE;
416 shi2_max_uses := High(Cardinal);
417 shi2_passwd := '';
418 end;
419 NetShareAdd(nil, 2, @ShareInfo, Err);
420 end else begin
421 NetShareDel(nil, MainSharedFolderName, 0);
422 end;
423end;
424
425procedure TMainForm.Init;
426var
427 Hostname: string;
428begin
429 HostName := 'default';
430
431 //DefaultGateway := GetDefaultGateway;
432 //if AutoDial then Dial;
433end;
434
435function GetIPFromHost(var HostName, IPaddr, WSAErr: string): Boolean;
436type
437 Name = array[0..100] of Char;
438 PName = ^Name;
439var
440 HEnt: pHostEnt;
441 HName: PName;
442 WSAData: TWSAData;
443 i: Integer;
444begin
445 Result := False;
446 if WSAStartup($0101, WSAData) <> 0 then begin
447 WSAErr := 'Winsock is not responding."';
448 Exit;
449 end;
450 IPaddr := '';
451 New(HName);
452 if GetHostName(HName^, SizeOf(Name)) = 0 then
453 begin
454 HostName := StrPas(HName^);
455 HEnt := GetHostByName(HName^);
456 for i := 0 to HEnt^.h_length - 1 do
457 IPaddr :=
458 Concat(IPaddr,
459 IntToStr(Ord(HEnt^.h_addr_list^[i])) + '.');
460 SetLength(IPaddr, Length(IPaddr) - 1);
461 Result := True;
462 end
463 else begin
464 case WSAGetLastError of
465 WSANOTINITIALISED:WSAErr:='WSANotInitialised';
466 WSAENETDOWN :WSAErr:='WSAENetDown';
467 WSAEINPROGRESS :WSAErr:='WSAEInProgress';
468 end;
469 end;
470 Dispose(HName);
471 WSACleanup;
472end;
473
474procedure TMainForm.LoadOptions;
475begin
476 with TRegistry.Create do
477 try
478 RootKey := RegistryRootKey;
479 OpenKey(RegistryPath, True);
480 if ValueExists('FirstStart') then FirstStart := ReadBool('FirstStart')
481 else FirstStart := False;
482 if ValueExists('NetworkTestLastUpdate') then NetworkTestLastUpdate := StrToDate(ReadString('NetworkTestLastUpdate'));
483 if ValueExists('PingTimeout') then PingTimeout := ReadInteger('PingTimeout')
484 else PingTimeout := 200;
485 finally
486 Free;
487 end;
488end;
489
490procedure TMainForm.SaveOptions;
491begin
492 with TRegistry.Create do
493 try
494 RootKey := RegistryRootKey;
495 OpenKey(RegistryPath, True);
496 WriteBool('FirstStart', True);
497 WriteString('NetworkTestLastUpdate', DateToStr(NetworkTestLastUpdate));
498 WriteInteger('PingTimeout', PingTimeout);
499 finally
500 Free;
501 end;
502end;
503
504function TMainForm.GetNetworkDomain: string;
505var
506 Command: TDosCommand;
507 I: Integer;
508 Lines2: TStringList;
509begin
510 Lines2 := TStringList.Create;
511 Result := '';
512 Command := TDosCommand.Create(nil);
513 with Command do try
514 CommandLine := 'ipconfig /all';
515 OutputLines := Lines2;
516 Execute2;
517 for I := 0 to Lines2.Count - 1 do
518 if Pos('Prohledávací seznam pøípon DNS', Lines2[I]) > 0 then
519 Result := Copy(Lines2[I], Pos(':', Lines2[I]) + 2, 255);
520 finally
521 Free;
522 Lines2.Free;
523 end;
524end;
525
526end.
Note: See TracBrowser for help on using the repository browser.