Login | ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/alarming/trunk/Delphi Client/DoorAlarmClientMain.pas
Revision: 9
Committed: Thu May 21 18:24:45 2020 UTC (4 months, 1 week ago) by daniel-marschall
Content type: text/x-pascal
File size: 14144 byte(s)
Log Message:
Simulate alarm

File Contents

# Content
1 unit DoorAlarmClientMain;
2
3 // TODO: make configurable, which actions should be executed (e.g. run programs) when a motion was detected, with different event sounds etc
4 // TODO: ask server to subscribe/unsubscribe to events (doorbell, motion)
5
6 interface
7
8 uses
9 Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
10 Dialogs, HTTPApp, StdCtrls,
11 IdHTTPServer, idContext, idCustomHTTPServer, OleCtrls, SHDocVw, ExtCtrls,
12 JPEG, MJPEGDecoderUnit, IniFiles, Menus;
13
14 type
15 TAlarmType = (atUnknown, atMotion, atDoorbell);
16
17 TForm1 = class(TForm)
18 Image1: TImage;
19 TrayIcon1: TTrayIcon;
20 PopupMenu1: TPopupMenu;
21 Exit1: TMenuItem;
22 Open1: TMenuItem;
23 Image2: TImage;
24 CloseTimer: TTimer;
25 UpdateIPTimer: TTimer;
26 Allowmutingsoundinterface1: TMenuItem;
27 N1: TMenuItem;
28 Startalarm1: TMenuItem;
29 N2: TMenuItem;
30 Stopalarm1: TMenuItem;
31 Gotocontrolpanelwebsite1: TMenuItem;
32 doorbellPanel: TPanel;
33 N3: TMenuItem;
34 Ignoredoorbell1: TMenuItem;
35 Ignoremotionalert1: TMenuItem;
36 unknownAlarm: TPanel;
37 Simulatealarm1: TMenuItem;
38 procedure FormDestroy(Sender: TObject);
39 procedure FormCreate(Sender: TObject);
40 procedure TrayIcon1Click(Sender: TObject);
41 procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
42 procedure Exit1Click(Sender: TObject);
43 procedure Open1Click(Sender: TObject);
44 procedure FormShow(Sender: TObject);
45 procedure FormHide(Sender: TObject);
46 procedure CloseTimerTimer(Sender: TObject);
47 procedure UpdateIPTimerTimer(Sender: TObject);
48 procedure Startalarm1Click(Sender: TObject);
49 procedure Stopalarm1Click(Sender: TObject);
50 procedure Gotocontrolpanelwebsite1Click(Sender: TObject);
51 procedure ImageClick(Sender: TObject);
52 procedure Simulatealarm1Click(Sender: TObject);
53 private
54 MJPEGDecoder: TMJPEGDecoder;
55 LastDingDong: TDateTime;
56 SimpleCS: boolean;
57 ini: TMemIniFile;
58 last_known_webcam_port: integer;
59 procedure ServerCommandGet(AContext: TIdContext; ARequestInfo: TIdHTTPRequestInfo; AResponseInfo: TIdHTTPResponseInfo);
60 procedure MotionDetected;
61 procedure HandleFrame(Sender: TObject; Frame: TJPEGImage);
62 procedure WMQueryEndSession(var Message: TWMQueryEndSession); message WM_QUERYENDSESSION;
63 procedure StartStream;
64 procedure StopStream;
65 procedure DoShowForm(AlarmType: TAlarmType);
66 procedure DoPosition;
67 procedure StopMusic;
68 function ControlServerUrl: string;
69 end;
70
71 var
72 Form1: TForm1;
73
74 implementation
75
76 {$R *.dfm}
77
78 uses
79 mmSystem, idhttp, DateUtils, ActiveX, ComObj, AudioVolCntrl, ShellAPI;
80
81 var
82 Server: TIdHTTPServer;
83 gShuttingDown: boolean;
84
85 procedure CallUrl(const url: string);
86 var
87 idhttp: TIdHTTP;
88 begin
89 if url <> '' then
90 begin
91 idhttp := TIdHTTP.Create(nil);
92 try
93 idhttp.Get(url);
94 finally
95 FreeAndNil(idhttp);
96 end;
97 end;
98 end;
99
100 procedure TForm1.Stopalarm1Click(Sender: TObject);
101 var
102 lParamList: TStringList;
103 idhttp: TIdHttp;
104 begin
105 //try
106 try
107 UpdateIPTimerTimer(UpdateIPTimer); // make sure we are registered
108
109 lParamList := TStringList.Create;
110 lParamList.Add('action=motion_off'); // 1.3.6.1.4.1.37476.2.4.1.101
111
112 idhttp := TIdHTTP.Create(nil);
113 try
114 idhttp.Post(ControlServerUrl, lParamList);
115 finally
116 FreeAndNil(idhttp);
117 end;
118 finally
119 FreeAndNil(lParamList);
120 end;
121 //except
122 // Nothing
123 //end;
124 end;
125
126 procedure TForm1.StopMusic;
127 const
128 TIMEOUT = 1000; // ms
129 var
130 lpdwResult: DWORD;
131 begin
132 // Stops Spotify, WMP, etc.
133 lpdwResult := 0;
134 SendMessageTimeout(HWND_BROADCAST, WM_APPCOMMAND, 0, MAKELONG(0, APPCOMMAND_MEDIA_STOP), SMTO_NORMAL, TIMEOUT, lpdwResult);
135
136 // Mutes everything (also YouTube)
137 if Allowmutingsoundinterface1.Checked then
138 begin
139 OleCheck(CoInitialize(nil));
140 try
141 MuteAllAudioDevices(true);
142 finally
143 CoUninitialize;
144 end;
145 end;
146 end;
147
148 procedure TForm1.HandleFrame(Sender: TObject; Frame: TJPEGImage);
149 begin
150 try
151 Image1.Picture.Bitmap.Assign(Frame);
152
153 Left := Left + (ClientWidth - Image1.Picture.Width);
154 Top := Top + (ClientHeight - Image1.Picture.Height);
155
156 ClientWidth := Image1.Picture.Width;
157 ClientHeight := Image1.Picture.Height;
158 finally
159 Frame.Free;
160 end;
161 end;
162
163 procedure TForm1.ImageClick(Sender: TObject);
164 (*
165 var
166 pnt: TPoint;
167 *)
168 begin
169 (*
170 if GetCursorPos(pnt) then
171 PopupMenu1.Popup(pnt.X, pnt.Y);
172 *)
173 end;
174
175 procedure TForm1.WMQueryEndSession(var Message: TWMQueryEndSession);
176 begin
177 gShuttingDown := true;
178 Message.Result := 1;
179 end;
180
181 procedure TForm1.Startalarm1Click(Sender: TObject);
182 var
183 lParamList: TStringList;
184 idhttp: TIdHttp;
185 begin
186 //try
187 try
188 UpdateIPTimerTimer(UpdateIPTimer); // make sure we are registered
189
190 lParamList := TStringList.Create;
191 lParamList.Add('action=motion_on'); // 1.3.6.1.4.1.37476.2.4.1.100
192
193 idhttp := TIdHTTP.Create(nil);
194 try
195 idhttp.Post(ControlServerUrl, lParamList);
196 finally
197 FreeAndNil(idhttp);
198 end;
199 finally
200 FreeAndNil(lParamList);
201 end;
202 //except
203 // Nothing
204 //end;
205 end;
206
207 procedure TForm1.StartStream;
208 begin
209 if last_known_webcam_port = 0 then exit;
210
211 MJPEGDecoder.OnFrame := HandleFrame;
212 MJPEGDecoder.OnError := nil;
213 MJPEGDecoder.OnMessage := nil;
214 MJPEGDecoder.Connect(ini.ReadString('Server', 'Address', '127.0.0.1'),
215 last_known_webcam_port,
216 '/');
217 end;
218
219 procedure TForm1.StopStream;
220 begin
221 MJPEGDecoder.Disconnect;
222 end;
223
224 procedure TForm1.CloseTimerTimer(Sender: TObject);
225 begin
226 CloseTimer.Enabled := false;
227 Close;
228 end;
229
230 procedure TForm1.MotionDetected;
231 var
232 AlarmSound: string;
233 DingDongMinInterval: integer;
234 begin
235 DingDongMinInterval := ini.ReadInteger('Sound', 'AlarmMinInterval', 10);
236 if SecondsBetween(Now, LastDingDong) > DingDongMinInterval then
237 begin
238 LastDingDong := Now;
239
240 if ini.ReadBool('Sound', 'StopMusic', true) then
241 begin
242 StopMusic;
243 end;
244
245 AlarmSound := ini.ReadString('Sound', 'AlarmSoundFile', '');
246 if AlarmSound <> '' then
247 begin
248 PlaySound(PChar(AlarmSound), 0, SND_ALIAS or SND_ASYNC);
249 end;
250 end;
251 end;
252
253 procedure TForm1.Exit1Click(Sender: TObject);
254 begin
255 gShuttingDown := true;
256 Close;
257 end;
258
259 procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
260 begin
261 CloseTimer.Enabled := false;
262 CanClose := gShuttingDown;
263 if not CanClose then Hide;
264 end;
265
266 procedure TForm1.FormCreate(Sender: TObject);
267 begin
268 ini := TMemIniFile.Create(ChangeFileExt(Application.ExeName, '.ini'));
269
270 DoubleBuffered := true;
271
272 Server := TIdHTTPServer.Create();
273 Server.DefaultPort := ini.ReadInteger('Client', 'ListenPort', 80);
274 Server.OnCommandGet := ServerCommandGet;
275 Server.Active := true;
276
277 Gotocontrolpanelwebsite1.Visible := true;
278 Startalarm1.Visible := true;
279 Stopalarm1.Visible := true;
280 N2.Visible := Gotocontrolpanelwebsite1.Visible or Startalarm1.Visible or Stopalarm1.Visible;
281
282 MJPEGDecoder := TMJPEGDecoder.Create(Self);
283
284 DoPosition;
285
286 // Question: Should these settings also be saved for the next program session?
287 Allowmutingsoundinterface1.Checked := ini.ReadBool('Client', 'AllowMute', false);
288 Ignoredoorbell1.Checked := ini.ReadBool('Client', 'IgnoreDoorbell', false);
289 Ignoremotionalert1.Checked := ini.ReadBool('Client', 'IgnoreMotion', false);
290
291 UpdateIPTimerTimer(UpdateIPTimer);
292 UpdateIPTimer.Interval := ini.ReadInteger('Client', 'SubscribeInterval', 30*60) * 1000;
293 UpdateIPTimer.Enabled := true;
294 end;
295
296 procedure TForm1.FormDestroy(Sender: TObject);
297 begin
298 if Assigned(Server) then Server.Active := false;
299 FreeAndNil(Server);
300
301 FreeAndNil(ini);
302
303 FreeAndNil(MJPEGDecoder);
304 end;
305
306 procedure TForm1.FormHide(Sender: TObject);
307 begin
308 if Image2.Visible then
309 StopStream;
310 end;
311
312 procedure TForm1.FormShow(Sender: TObject);
313 begin
314 if Image2.Visible then
315 StartStream;
316 end;
317
318 procedure TForm1.Gotocontrolpanelwebsite1Click(Sender: TObject);
319 begin
320 ShellExecute(Handle, 'open', PChar(ControlServerUrl), '', '', SW_NORMAL);
321 end;
322
323 procedure TForm1.Open1Click(Sender: TObject);
324 begin
325 TrayIcon1Click(TrayIcon1);
326 end;
327
328 procedure TForm1.ServerCommandGet(AContext: TIdContext; ARequestInfo: TIdHTTPRequestInfo; AResponseInfo: TIdHTTPResponseInfo);
329 var
330 AutoCloseTimerInterval: integer;
331 AlarmType: TAlarmType;
332 begin
333 aResponseInfo.ResponseNo := 200;
334 aResponseInfo.ContentType := 'text/html';
335 aResponseInfo.ContentText := '';
336
337 if (ARequestInfo.CommandType = hcPOST) and
338 (ARequestInfo.Params.Values['action'] = 'client_alert') then // 1.3.6.1.4.1.37476.2.4.1.3
339 begin
340 if ARequestInfo.Params.Values['motion_port'] <> '' then
341 begin
342 TryStrToInt(ARequestInfo.Params.Values['motion_port'], last_known_webcam_port);
343 end;
344
345 if ARequestInfo.Params.Values['simulation'] = '1' then
346 begin
347 exit;
348 end;
349
350 if SimpleCS then exit;
351 SimpleCS := true;
352 try
353 if CloseTimer.Enabled then
354 begin
355 CloseTimer.Enabled := false;
356 CloseTimer.Enabled := true; // "Restart" timer
357 end;
358
359 AutoCloseTimerInterval := ini.ReadInteger('Client', 'AutoCloseTimer', 5000);
360 if (not Visible) and (AutoCloseTimerInterval <> -1) then
361 begin
362 CloseTimer.Interval := AutoCloseTimerInterval;
363 CloseTimer.Enabled := true;
364 end;
365
366 if ARequestInfo.Params.IndexOf('targets=1.3.6.1.4.1.37476.2.4.2.1002' {camera, motion}) >= 0 then
367 AlarmType := atMotion
368 else if ARequestInfo.Params.IndexOf('targets=1.3.6.1.4.1.37476.2.4.2.2001' {sound, doorbell}) >= 0 then
369 AlarmType := atDoorbell
370 else
371 begin
372 // TODO: Make plugin DLLs ?
373 AlarmType := atUnknown;
374 end;
375
376 // Attention: Ignoring these events at the client does not prevent the server
377 // doing other actions (e.g. ask Spotify to stop the music on connected devices)
378 if Ignoredoorbell1.Checked and (AlarmType = atDoorbell) then Exit;
379 if Ignoremotionalert1.Checked and (AlarmType = atMotion) then Exit;
380
381 if AlarmType = atUnknown then
382 begin
383 unknownAlarm.ShowHint := true;
384 unknownAlarm.Hint := ARequestInfo.Params.Text;
385 end;
386 DoShowForm(AlarmType);
387
388 if ini.ReadBool('Client', 'AutoPopup', true) then
389 begin
390 Application.Restore;
391 WindowState := wsNormal;
392 end;
393
394 if ini.ReadBool('Client', 'AlarmStayOnTop', true) then
395 FormStyle := fsStayOnTop
396 else
397 FormStyle := fsNormal;
398
399 MotionDetected;
400 finally
401 SimpleCS := false;
402 end;
403 end;
404 end;
405
406 procedure TForm1.Simulatealarm1Click(Sender: TObject);
407 var
408 lParamList: TStringList;
409 idhttp: TIdHttp;
410 begin
411 //try
412 try
413 lParamList := TStringList.Create;
414 lParamList.Add('action=server_alert'); // 1.3.6.1.4.1.37476.2.4.1.2
415 lParamList.Add('targets=1.3.6.1.4.1.37476.2.4.2.0'); // Any
416 lParamList.Add('targets=1.3.6.1.4.1.37476.2.4.2.1002'); // Motion, camera
417 lParamList.Add('targets=1.3.6.1.4.1.37476.2.4.2.2001'); // Sound, doorbell
418
419 idhttp := TIdHTTP.Create(nil);
420 try
421 idhttp.Post(ControlServerUrl, lParamList);
422 finally
423 FreeAndNil(idhttp);
424 end;
425 finally
426 FreeAndNil(lParamList);
427 end;
428 //except
429 // Nothing
430 //end;
431 end;
432
433 procedure TForm1.TrayIcon1Click(Sender: TObject);
434 begin
435 // TODO: when clicked, the icon-selection won't close
436 Application.Restore;
437 WindowState := wsNormal;
438 FormStyle := fsNormal;
439 DoShowForm(atMotion);
440 end;
441
442 procedure TForm1.UpdateIPTimerTimer(Sender: TObject);
443 var
444 lParamList: TStringList;
445 idhttp: TIdHttp;
446 begin
447 try
448 try
449 lParamList := TStringList.Create;
450 lParamList.Add('action=client_subscribe'); // 1.3.6.1.4.1.37476.2.4.1.1
451 lParamList.Add('port='+ini.ReadString('Client', 'ListenPort', ''));
452 lParamList.Add('ttl='+IntToStr((UpdateIPTimer.Interval div 1000) * 2 + 10));
453 lParamList.Add('targets=1.3.6.1.4.1.37476.2.4.2.0'); // Any
454 lParamList.Add('targets=1.3.6.1.4.1.37476.2.4.2.1002'); // Motion, camera
455 lParamList.Add('targets=1.3.6.1.4.1.37476.2.4.2.2001'); // Sound, doorbell
456
457 idhttp := TIdHTTP.Create(nil);
458 try
459 idhttp.Post(ControlServerUrl, lParamList);
460 finally
461 FreeAndNil(idhttp);
462 end;
463 finally
464 FreeAndNil(lParamList);
465 end;
466 except
467 // Nothing
468 end;
469 end;
470
471 function TForm1.ControlServerUrl: string;
472 begin
473 result := 'http://' + ini.ReadString('Server', 'Address', '127.0.0.1') + ':' + ini.ReadString('Server', 'Port', '80') + '/';
474 end;
475
476 procedure TForm1.DoPosition;
477 function _TaskBarHeight: integer;
478 var
479 hTB: HWND;
480 TBRect: TRect;
481 begin
482 hTB := FindWindow('Shell_TrayWnd', '');
483 if hTB = 0 then
484 Result := 0
485 else
486 begin
487 GetWindowRect(hTB, TBRect);
488 Result := TBRect.Bottom - TBRect.Top;
489 end;
490 end;
491 begin
492 // TODO: modify this code so that it works also if the task bar is on top or on the right corner of the screen
493 // TODO: user should select in which corner the window show be
494 Self.Left := Screen.Width - Self.Width;
495 Self.Top := Screen.Height - Self.Height - _TaskBarHeight;
496 end;
497
498 procedure TForm1.DoShowForm(AlarmType: TAlarmType);
499 begin
500 Image1.Visible := AlarmType = atMotion;
501 Image2.Visible := AlarmType = atMotion;
502
503 // BUGBUG! TODO: This does not work. The panels are not visible for some reason! I just get a white window!
504 doorbellPanel.Visible := AlarmType = atDoorbell;
505 unknownAlarm.Visible := AlarmType = atUnknown;
506
507 if ini.ReadBool('Client', 'AutoReposition', true) then
508 begin
509 DoPosition;
510 end;
511
512 Show;
513 end;
514
515 end.