Login | ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/alarming/trunk/Delphi Client/DoorAlarmClientMain.pas
Revision: 7
Committed: Mon Jun 10 21:58:29 2019 UTC (15 months, 2 weeks ago) by daniel-marschall
Content type: text/x-pascal
File size: 13155 byte(s)
Log Message:
Delphi: Implemented doorbell handler

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