1 // SPDX-License-Identifier: LGPL-3.0-only (modified to allow linking)
2 {******************************* CONTRIBUTOR(S) ******************************
3 - Edivando S. Santos Brasil | mailedivando@gmail.com
4   (Compatibility with delphi VCL 11/2018)
5 
6 ***************************** END CONTRIBUTOR(S) *****************************}
7 unit BCKeyboard;
8 
9 {$I bgracontrols.inc}
10 
11 interface
12 
13 uses
14   Classes, SysUtils, {$IFDEF FPC}LCLType, LResources, LMessages,{$ENDIF}Forms, Controls, Graphics, Dialogs,
15   {$IFNDEF FPC}Types, Windows, Messages, BGRAGraphics, GraphType, FPImage, BCBaseCtrls,{$ENDIF}
16   BCThemeManager, BCButton, BCPanel, MouseAndKeyInput;
17 
18 type
19 
20   { TBCKeyboard }
21 
22   TBCKeyboard = class(TComponent)
23   private
24     FBCThemeManager: TBCThemeManager;
25     FButton: TBCButton;
26     FOnUserChange: TNotifyEvent;
27     FPanel, FRow1, FRow2, FRow3, FRow4: TBCPanel;
28     FPanelsColor: TColor;
29     F_q, F_w, F_e, F_r, F_t, F_y, F_u, F_i, F_o, F_p, F_a, F_s, F_d,
30     F_f, F_g, F_h, F_j, F_k, F_l, F_z, F_x, F_c, F_v, F_b, F_n, F_m,
31     F_shift, F_space, F_back: TBCButton;
32     FVisible: boolean;
33     procedure SetFButton(AValue: TBCButton);
34     procedure SetFPanel(AValue: TBCPanel);
35     procedure SetFPanelsColor(AValue: TColor);
36     procedure SetFThemeManager(AValue: TBCThemeManager);
37   protected
38     procedure PressVirtKey(p: longint);
39     procedure PressShiftVirtKey(p: longint);
40     procedure OnButtonClick(Sender: TObject; {%H-}Button: TMouseButton;
41       {%H-}Shift: TShiftState; {%H-}X, {%H-}Y: integer); virtual;
42     { When value is changed by the user }
43     property OnUserChange: TNotifyEvent read FOnUserChange write FOnUserChange;
44   public
45     constructor Create(AOwner: TComponent); override;
46     destructor Destroy; override;
47     // Show in a custom form or panel
48     procedure Show(AControl: TWinControl); overload;
49     // Try to Show in the form where this component is placed
50     procedure Show(); overload;
51     // Hide the component
52     procedure Hide();
53     // Update buttons style
54     procedure UpdateButtonStyle;
55   public
56     { The real panel that's used as container for all the numeric buttons }
57     property Panel: TBCPanel read FPanel write SetFPanel;
58     { The color of all the panels involved in the control }
59     property PanelsColor: TColor read FPanelsColor write SetFPanelsColor;
60     { A fake button that's used as style base for all the numeric buttons }
61     property ButtonStyle: TBCButton read FButton write SetFButton;
62     { If it's visible or not }
63     property Visible: boolean read FVisible;
64   published
65     property ThemeManager: TBCThemeManager read FBCThemeManager write SetFThemeManager;
66   end;
67 
68 {$IFDEF FPC}procedure Register;{$ENDIF}
69 
70 implementation
71 
72 {$IFDEF FPC}procedure Register;
73 begin
74   RegisterComponents('BGRA Controls', [TBCKeyboard]);
75 end;
76 {$ENDIF}
77 
78 { TBCKeyboard }
79 
80 procedure TBCKeyboard.SetFThemeManager(AValue: TBCThemeManager);
81 begin
82   if FBCThemeManager = AValue then
83     Exit;
84   FBCThemeManager := AValue;
85 end;
86 
87 procedure TBCKeyboard.PressVirtKey(p: longint);
88 begin
89   KeyInput.Down(p);
90   KeyInput.Up(p);
91 end;
92 
93 procedure TBCKeyboard.PressShiftVirtKey(p: longint);
94 begin
95   KeyInput.Down(VK_SHIFT);
96   KeyInput.Down(p);
97   KeyInput.Up(p);
98   KeyInput.Up(VK_SHIFT);
99 end;
100 
101 procedure TBCKeyboard.OnButtonClick(Sender: TObject; Button: TMouseButton;
102   Shift: TShiftState; X, Y: integer);
103 var
104   btn: TBCButton;
105   str: string;
106 begin
107   btn := TBCButton(Sender);
108   str := btn.Caption;
109 
110   if str = F_shift.Caption then
111   begin
112     F_shift.Down := not F_shift.Down;
113     if not F_shift.Down then
114     begin
115       F_q.Caption := LowerCase(F_q.Caption);
116       F_w.Caption := LowerCase(F_w.Caption);
117       F_e.Caption := LowerCase(F_e.Caption);
118       F_r.Caption := LowerCase(F_r.Caption);
119       F_t.Caption := LowerCase(F_t.Caption);
120       F_y.Caption := LowerCase(F_y.Caption);
121       F_u.Caption := LowerCase(F_u.Caption);
122       F_i.Caption := LowerCase(F_i.Caption);
123       F_o.Caption := LowerCase(F_o.Caption);
124       F_p.Caption := LowerCase(F_p.Caption);
125       F_a.Caption := LowerCase(F_a.Caption);
126       F_s.Caption := LowerCase(F_s.Caption);
127       F_d.Caption := LowerCase(F_d.Caption);
128       F_f.Caption := LowerCase(F_f.Caption);
129       F_g.Caption := LowerCase(F_g.Caption);
130       F_h.Caption := LowerCase(F_h.Caption);
131       F_j.Caption := LowerCase(F_j.Caption);
132       F_k.Caption := LowerCase(F_k.Caption);
133       F_l.Caption := LowerCase(F_l.Caption);
134       F_z.Caption := LowerCase(F_z.Caption);
135       F_x.Caption := LowerCase(F_x.Caption);
136       F_c.Caption := LowerCase(F_c.Caption);
137       F_v.Caption := LowerCase(F_v.Caption);
138       F_b.Caption := LowerCase(F_b.Caption);
139       F_n.Caption := LowerCase(F_n.Caption);
140       F_m.Caption := LowerCase(F_m.Caption);
141     end
142     else
143     begin
144       F_q.Caption := UpperCase(F_q.Caption);
145       F_w.Caption := UpperCase(F_w.Caption);
146       F_e.Caption := UpperCase(F_e.Caption);
147       F_r.Caption := UpperCase(F_r.Caption);
148       F_t.Caption := UpperCase(F_t.Caption);
149       F_y.Caption := UpperCase(F_y.Caption);
150       F_u.Caption := UpperCase(F_u.Caption);
151       F_i.Caption := UpperCase(F_i.Caption);
152       F_o.Caption := UpperCase(F_o.Caption);
153       F_p.Caption := UpperCase(F_p.Caption);
154       F_a.Caption := UpperCase(F_a.Caption);
155       F_s.Caption := UpperCase(F_s.Caption);
156       F_d.Caption := UpperCase(F_d.Caption);
157       F_f.Caption := UpperCase(F_f.Caption);
158       F_g.Caption := UpperCase(F_g.Caption);
159       F_h.Caption := UpperCase(F_h.Caption);
160       F_j.Caption := UpperCase(F_j.Caption);
161       F_k.Caption := UpperCase(F_k.Caption);
162       F_l.Caption := UpperCase(F_l.Caption);
163       F_z.Caption := UpperCase(F_z.Caption);
164       F_x.Caption := UpperCase(F_x.Caption);
165       F_c.Caption := UpperCase(F_c.Caption);
166       F_v.Caption := UpperCase(F_v.Caption);
167       F_b.Caption := UpperCase(F_b.Caption);
168       F_n.Caption := UpperCase(F_n.Caption);
169       F_m.Caption := UpperCase(F_m.Caption);
170     end;
171   end
172   else if str = F_back.Caption then
173   begin
174     {$IFDEF CPUX86_64}
175     Application.ProcessMessages;
176     KeyInput.Press(VK_BACK);
177     Application.ProcessMessages;
178     {$ELSE}
179       {$IFDEF FPC}
180       Application.QueueAsyncCall(@PressVirtKey, VK_BACK);
181       {$ELSE}
182       SendKey(VK_BACK);
183       {$ENDIF}
184     {$ENDIF}
185   end
186   else
187   begin
188     if str = F_space.Caption then
189       str := ' ';
190     {$IFDEF CPUX86_64}
191     Application.ProcessMessages;
192     if F_shift.Down then
193       KeyInput.Down(VK_SHIFT);
194     KeyInput.Press(Ord(UpperCase(str)[1]));
195     if F_shift.Down then
196       KeyInput.Up(VK_SHIFT);
197     Application.ProcessMessages;
198     {$ELSE}
199     if F_shift.Down then
200       {$IFDEF FPC}
201       Application.QueueAsyncCall(@PressShiftVirtKey, Ord(UpperCase(str)[1]))
202       {$ELSE}
203       SendKey(Ord(UpperCase(str)[1]), Shift)
204       {$ENDIF}
205     else
206       {$IFDEF FPC}
207       Application.QueueAsyncCall(@PressVirtKey, Ord(UpperCase(str)[1]));
208       {$ELSE}
209       SendKey(Ord(UpperCase(str)[1]))
210       {$ENDIF}
211     {$ENDIF}
212   end;
213 
214   if Assigned(FOnUserChange) then
215     FOnUserChange(Self);
216 end;
217 
218 constructor TBCKeyboard.Create(AOwner: TComponent);
219 begin
220   inherited Create(AOwner);
221 
222   FVisible := False;
223 
224   FButton := TBCButton.Create(Self);
225 
226   FPanel := TBCPanel.Create(Self);
227   FPanel.AutoSize := True;
228   FPanel.ChildSizing.ControlsPerLine := 1;
229   FPanel.ChildSizing.Layout := cclLeftToRightThenTopToBottom;
230   FPanel.Caption := 'Panel1';
231   FPanel.BorderBCStyle := bpsBorder;
232 
233   { qwertyuiop }
234 
235   FRow1 := TBCPanel.Create(FPanel);
236   FRow1.AutoSize := True;
237   FRow1.Caption := '';
238   FRow1.BorderBCStyle := bpsBorder;
239   FRow1.ChildSizing.ControlsPerLine := 10;
240   FRow1.ChildSizing.Layout := cclLeftToRightThenTopToBottom;
241   FRow1.Parent := FPanel;
242 
243   F_q := TBCButton.Create(FRow1);
244   F_q.Caption := 'Q';
245   F_q.Parent := FRow1;
246   F_q.OnMouseDown := OnButtonClick;
247 
248   F_w := TBCButton.Create(FRow1);
249   F_w.Caption := 'W';
250   F_w.Parent := FRow1;
251   F_w.OnMouseDown := OnButtonClick;
252 
253   F_e := TBCButton.Create(FRow1);
254   F_e.Caption := 'E';
255   F_e.Parent := FRow1;
256   F_e.OnMouseDown := OnButtonClick;
257 
258   F_r := TBCButton.Create(FRow1);
259   F_r.Caption := 'R';
260   F_r.Parent := FRow1;
261   F_r.OnMouseDown := OnButtonClick;
262 
263   F_t := TBCButton.Create(FRow1);
264   F_t.Caption := 'T';
265   F_t.Parent := FRow1;
266   F_t.OnMouseDown := OnButtonClick;
267 
268   F_y := TBCButton.Create(FRow1);
269   F_y.Caption := 'Y';
270   F_y.Parent := FRow1;
271   F_y.OnMouseDown := OnButtonClick;
272 
273   F_u := TBCButton.Create(FRow1);
274   F_u.Caption := 'U';
275   F_u.Parent := FRow1;
276   F_u.OnMouseDown := OnButtonClick;
277 
278   F_i := TBCButton.Create(FRow1);
279   F_i.Caption := 'I';
280   F_i.Parent := FRow1;
281   F_i.OnMouseDown := OnButtonClick;
282 
283   F_o := TBCButton.Create(FRow1);
284   F_o.Caption := 'O';
285   F_o.Parent := FRow1;
286   F_o.OnMouseDown := OnButtonClick;
287 
288   F_p := TBCButton.Create(FRow1);
289   F_p.Caption := 'P';
290   F_p.Parent := FRow1;
291   F_p.OnMouseDown := OnButtonClick;
292 
293 
294   { asdfghjkl }
295 
296   FRow2 := TBCPanel.Create(FPanel);
297   FRow2.AutoSize := True;
298   FRow2.Caption := '';
299   FRow2.BorderBCStyle := bpsBorder;
300   FRow2.ChildSizing.ControlsPerLine := 9;
301   FRow2.ChildSizing.Layout := cclLeftToRightThenTopToBottom;
302   FRow2.Parent := FPanel;
303 
304   F_a := TBCButton.Create(FRow2);
305   F_a.Caption := 'A';
306   F_a.Parent := FRow2;
307   F_a.OnMouseDown := OnButtonClick;
308 
309   F_s := TBCButton.Create(FRow2);
310   F_s.Caption := 'S';
311   F_s.Parent := FRow2;
312   F_s.OnMouseDown := OnButtonClick;
313 
314   F_d := TBCButton.Create(FRow2);
315   F_d.Caption := 'D';
316   F_d.Parent := FRow2;
317   F_d.OnMouseDown := OnButtonClick;
318 
319   F_f := TBCButton.Create(FRow2);
320   F_f.Caption := 'F';
321   F_f.Parent := FRow2;
322   F_f.OnMouseDown := OnButtonClick;
323 
324   F_g := TBCButton.Create(FRow2);
325   F_g.Caption := 'G';
326   F_g.Parent := FRow2;
327   F_g.OnMouseDown := OnButtonClick;
328 
329   F_h := TBCButton.Create(FRow2);
330   F_h.Caption := 'H';
331   F_h.Parent := FRow2;
332   F_h.OnMouseDown := OnButtonClick;
333 
334   F_j := TBCButton.Create(FRow2);
335   F_j.Caption := 'J';
336   F_j.Parent := FRow2;
337   F_j.OnMouseDown := OnButtonClick;
338 
339   F_k := TBCButton.Create(FRow2);
340   F_k.Caption := 'K';
341   F_k.Parent := FRow2;
342   F_k.OnMouseDown := OnButtonClick;
343 
344   F_l := TBCButton.Create(FRow2);
345   F_l.Caption := 'L';
346   F_l.Parent := FRow2;
347   F_l.OnMouseDown := OnButtonClick;
348 
349   { zxcvbnm }
350 
351   FRow3 := TBCPanel.Create(FPanel);
352   FRow3.AutoSize := True;
353   FRow3.Caption := '';
354   FRow3.BorderBCStyle := bpsBorder;
355   FRow3.ChildSizing.ControlsPerLine := 9;
356   FRow3.ChildSizing.Layout := cclLeftToRightThenTopToBottom;
357   FRow3.Parent := FPanel;
358 
359   F_shift := TBCButton.Create(FRow3);
360   F_shift.Caption := '^';
361   F_shift.Parent := FRow3;
362   F_shift.OnMouseDown := OnButtonClick;
363   F_shift.Down := True;
364 
365   F_z := TBCButton.Create(FRow3);
366   F_z.Caption := 'Z';
367   F_z.Parent := FRow3;
368   F_z.OnMouseDown := OnButtonClick;
369 
370   F_x := TBCButton.Create(FRow3);
371   F_x.Caption := 'X';
372   F_x.Parent := FRow3;
373   F_x.OnMouseDown := OnButtonClick;
374 
375   F_c := TBCButton.Create(FRow3);
376   F_c.Caption := 'C';
377   F_c.Parent := FRow3;
378   F_c.OnMouseDown := OnButtonClick;
379 
380   F_v := TBCButton.Create(FRow3);
381   F_v.Caption := 'V';
382   F_v.Parent := FRow3;
383   F_v.OnMouseDown := OnButtonClick;
384 
385   F_b := TBCButton.Create(FRow3);
386   F_b.Caption := 'B';
387   F_b.Parent := FRow3;
388   F_b.OnMouseDown := OnButtonClick;
389 
390   F_n := TBCButton.Create(FRow3);
391   F_n.Caption := 'N';
392   F_n.Parent := FRow3;
393   F_n.OnMouseDown := OnButtonClick;
394 
395   F_m := TBCButton.Create(FRow3);
396   F_m.Caption := 'M';
397   F_m.Parent := FRow3;
398   F_m.OnMouseDown := OnButtonClick;
399 
400   F_back := TBCButton.Create(FRow3);
401   F_back.Caption := '<-';
402   F_back.Parent := FRow3;
403   F_back.OnMouseDown := OnButtonClick;
404 
405   { shift space back }
406 
407   FRow4 := TBCPanel.Create(FPanel);
408   FRow4.AutoSize := True;
409   FRow4.Caption := '';
410   FRow4.BorderBCStyle := bpsBorder;
411   FRow4.ChildSizing.ControlsPerLine := 1;
412   FRow4.ChildSizing.Layout := cclLeftToRightThenTopToBottom;
413   FRow4.Parent := FPanel;
414 
415   F_space := TBCButton.Create(FRow4);
416   F_space.Caption := '____________________';
417   F_space.Parent := FRow4;
418   F_space.OnMouseDown := OnButtonClick;
419 end;
420 
421 destructor TBCKeyboard.Destroy;
422 begin
423   { Everything inside the panel will be freed }
424   FPanel.Free;
425   inherited Destroy;
426 end;
427 
428 procedure TBCKeyboard.Show(AControl: TWinControl);
429 begin
430   FPanel.Parent := AControl;
431   FVisible := True;
432 end;
433 
434 procedure TBCKeyboard.Show;
435 begin
436   if Self.Owner is TWinControl then
437     Show(Self.Owner as TWinControl)
438   else
439     raise Exception.Create('The parent is not TWinControl descendant.');
440 end;
441 
442 procedure TBCKeyboard.Hide;
443 begin
444   FPanel.Parent := nil;
445   FVisible := False;
446 end;
447 
448 procedure TBCKeyboard.UpdateButtonStyle;
449 var
450   shift_down: boolean;
451 begin
452   F_q.Assign(FButton);
453   F_w.Assign(FButton);
454   F_e.Assign(FButton);
455   F_r.Assign(FButton);
456   F_t.Assign(FButton);
457   F_y.Assign(FButton);
458   F_u.Assign(FButton);
459   F_i.Assign(FButton);
460   F_o.Assign(FButton);
461   F_p.Assign(FButton);
462   F_a.Assign(FButton);
463   F_s.Assign(FButton);
464   F_d.Assign(FButton);
465   F_f.Assign(FButton);
466   F_g.Assign(FButton);
467   F_h.Assign(FButton);
468   F_j.Assign(FButton);
469   F_k.Assign(FButton);
470   F_l.Assign(FButton);
471   F_z.Assign(FButton);
472   F_x.Assign(FButton);
473   F_c.Assign(FButton);
474   F_v.Assign(FButton);
475   F_b.Assign(FButton);
476   F_n.Assign(FButton);
477   F_m.Assign(FButton);
478 
479   shift_down := F_shift.Down;
480   F_shift.Assign(FButton);
481   F_shift.Down := shift_down;
482 
483   F_back.Assign(FButton);
484 
485   F_space.Assign(FButton);
486 end;
487 
488 procedure TBCKeyboard.SetFButton(AValue: TBCButton);
489 begin
490   if FButton = AValue then
491     Exit;
492   FButton := AValue;
493 end;
494 
495 procedure TBCKeyboard.SetFPanel(AValue: TBCPanel);
496 begin
497   if FPanel = AValue then
498     Exit;
499   FPanel := AValue;
500 end;
501 
502 procedure TBCKeyboard.SetFPanelsColor(AValue: TColor);
503 begin
504   if FPanelsColor = AValue then
505     Exit;
506   FPanelsColor := AValue;
507   FPanel.Background.Color := AValue;
508   FRow1.Background.Color := AValue;
509   FRow2.Background.Color := AValue;
510   FRow3.Background.Color := AValue;
511   FRow4.Background.Color := AValue;
512 end;
513 
514 end.
515