Petit paquet de composants pl_beanz

**BeanzMaster** · 11/10/2015, 20h19

Salut à tous je reviens vers vous ici avec le début d'un paquet de composants

Vous trouverez dedans 3 composants, 1 visuel et 2 non visuels :

TBZButton : La suite du composant présenté dans un précédent post. Je suis allé bien plus en avant, que mon besoin de départ. Il reste encore quelques détails à peaufiner mais dans l'ensemble ça va pas trop mal.
TBZThreadTimer : Juste le clone du composant TJVThreadTimer de la librairie JVCL
TBZHotKeyManager : La mise à jour du composant présenté également dans un précédent post. Maintenant on peut directement éditer les raccourcis dans l'IDE et j'ai fait quelques modifications

Vous trouverez également quelques démos pour pouvoir tester.

1. Je fais appel à vous car j'ai un bug qui m'ennuie. Dans TBZButton et dans TBZHotKeyManager lorsque l'on édite les Raccourcis Clavier dans l'IDE ceux-ci ne fonctionnent pas.
A contrario lorsqu'on les définit dynamiquement là pas de souci ils sont bien pris en compte. (cf les démos basic et dynamique pour tester).
Est dû à un bug de Lazarus ? Ai-je oublié quelque chose ? Je ne comprends pas où pourrait se situer mon erreur.

2. Dans le code de TBZButton vous trouverez quelques petits commentaires sur des petits bugs et autres infos diverses.

Voilà j'attend avec impatience vos impressions et suggestions.

pl_Beanz.zip

PS : J'ai compilé, installé et testé ce paquet et les démos dans Lazarus 1.4.2 32bits et dans CodeTyphon 64Bits sans problemes

Merci d'avance de votre aide

A Bientôt

**jurassic pork** · 16/10/2015, 03h05

hello,
peut-être une piste pour ton problème sur le gestionnaire de raccourcis :

Quand on rajoute un composant visuel TBzHotkeymanager sans rien modifier dans ses propriétés dans la démo hotkeys dynamic, le raccourci créé sur le oncreate de la fiche ne fonctionne plus.

Ami calmant, J.P

**BeanzMaster** · 16/10/2015, 13h13

Salut JP

Quand on rajoute un composant "NON" visuel TBzHotkeymanager sans rien modifier dans ses propriétés dans la démo hotkeys dynamic, le raccourci créé sur le oncreate de la fiche ne fonctionne plus.

Merci j'avais pas pensé à faire ce test. Cela doit donc provenir dans l'initialisation de la fiche et des composants, peut-être faudrait-il que je vérifie à la création des composants avec "Loaded" si me je souviens bien.
Je me demande si les ShortCuts sont stockés globalement au niveau de la Form ou de l'application. De ce fait l'ordre de création des composants ne serait pas correcte car initialisé avant. Ce qui expliquerai le pourquoi.
Je vais testé avec onShow au lieu de OnCreate pour voir.

Merci JP

**BeanzMaster** · 19/10/2015, 19h38

Salut à tous apres le message de JP j'ai parlé de loaded

et ben voila le bug de TBZHotKeyManager est résolu mais pour le shortcut de TBZButton c'est une autre histoire. Bref voila le code corrigé du composant TBZHotKeyManager

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
 
unit bz_HotKeyManager;
//==============================================================================
// @NAME    : BZApplicationHotKey
// @VERSION : 0.5.1
// @DATE    : 08/09/2015
// @UPDATED : 09/10/2015
// @PACKAGE : BEANZ
// @DESC    : TBZHotKeyManager est un composant multi-plateforme
//            (WINDOWS/LINUX/MAC) pour gérer et intercepter les raccourcis
//            claviers globaux du systeme d'exploitation.
//            Edition et gestion de la liste des raccourcis dans L'IDE
// @AUTHOR  : J.DELAUNEY Aka BeanzMaster
// @LICENCE : WTFPL
//------------------------------------------------------------------------------
// @NOTE    : Ce composant à uniquement été tester sous environnement WINDOWS 7
//            Il devrait être compatible sous Linux indépendemment de l'interface
//            utilisée Gnome, KDE, XFCE ect....
//            Il devrait être compatible sous Mac seulement et seulement si vous
//            utilisez GTK+ comme interface et la librairie X11 dans vos réalisations.
//            ATTIENTION pour être tester sous Mac en l'etat actuel, vous devrez
//            faire quelques modifications au niveau des directives de compilation
//------------------------------------------------------------------------------
// @TODO    :
//  - A Tester sous environnement Linux (gnome, kde ect..) et Mac
//  - Gérer les raccourcis sous Mac avec l'interface COCOA. CARBONE étant
//    maintenant devenue obsolète.
//
//==============================================================================
 
{$mode objfpc}{$H+}
 
interface
 
//==============================================================================
 
uses
  Classes, SysUtils, LResources,
  {$IFDEF WINDOWS}
  windows,
  {$ENDIF}
  {$IFDEF LINUX}
  x,  xlib, gdk2, gdk2x, cthread, cmem,
  {$ENDIF}
  {$IFDEF DARWIN}
    // Il semblrerait qu'en utilisant "NSEvent" il est possible d'intercepter les evenements clavier
    // à la fois sous Carbon et Cocoa. Mais aucune idées comment implémenter ça.
    {$IFDEF CARBON}
    //FPCMacOSAll,
    {$ELSE}
      // Only Carbon Interface is supported
    {$ENDIF}
  {$ENDIF}
  Forms, Controls, Graphics, Dialogs ;
 
//==============================================================================
 
{$IFDEF WINDOWS}
const
  WinClassName: string = 'HOTKEYBZAPPLICATIONHOTKEY';
  HotKeyAtomPrefix : string = 'BeanzHotKeyAtom';
{$ENDIF}
 
//==============================================================================
Type
  TOnHotKeyEvent = procedure(Index: Integer) of object;
 
//==============================================================================
//==== [ TBZHotKeyItem ]========================================================
//==============================================================================
Type
  TBZHotKeyItem = class(TCollectionItem)
   private
     FHotKey : TShortCut; //Cardinal;
     FKeyIndex : Integer;
     FOnExecute : TNotifyEvent;
   public
     constructor Create(ACollection: TCollection); override;
   published
     property HotKey: TShortCut read FHotKey write FHotKey;
     property Index: Integer read FKeyIndex Write FKeyIndex;
     property OnExecute:TNotifyEvent Read FOnExecute Write FOnExecute;
   end;
 
//==============================================================================
//==== [ TBZHotKeyList ]========================================================
//==============================================================================
   TBZHotKeyList = class(TCollection)
   private
     function GetItems(Index: integer): TBZHotKeyItem;
     procedure SetItems(Index: integer; AValue: TBZHotKeyItem);
   public
     constructor Create;
   public
     function Add: TBZHotKeyItem;
     property Items[Index: integer]: TBZHotKeyItem read GetItems write SetItems; default;
   end;
 
{$IFDEF LINUX}
Type TBZHotKeyManager = class;
//==============================================================================
//==== [ TBZXEventListener ]====================================================
//==============================================================================
Type
  TBZXEventListener = class(TThread)
  private
    FApplicationHotKeys : TBZHotKeyManager;
  protected
    procedure Execute; override;
  public
    constructor Create(AAppHotKey:TBZHotKeyManager);
  end;
{$ENDIF}
 
//==============================================================================
//==== [ TBZHotKeyManager ]=====================================================
//==============================================================================
type
  TBZHotKeyManager = class(TComponent)
  private
    { Private declarations }
    FActive : boolean;
    FHotKeyList : TBZHotKeyList;
    //FOnHotKey : TOnHotKeyEvent; //TNotifyEvent;
 
    //----------------------------------------------------------------------------
    // Variables pour intercepter les "HotKeys" sous Linux
    {$IFDEF LINUX}
       FXEventListener : TThread;  // Un thread pour intercepter les messages du systeme
    {$ENDIF}
 
    //--------------------------------------------------------------------------
    // Fonctions pour intercepter les "HotKeys" sous Windows
    {$IFDEF WINDOWS}
      function  CreateAppWindow: boolean;
    {$ENDIF}
 
    //--------------------------------------------------------------------------
    // Fonctions internes du composant pour construire et detruire les raccourcis
    function DoRegisterHotKey(hk:Cardinal):integer;
    function DoUnregisterHotKey(KeyIndex:integer):boolean;
 
    // Lancement de notre evenement à l'interception d'un raccourci
    procedure DoOnHotKey(Index: Integer);
 
    procedure SetActive(Value: Boolean);
 
 
 
  protected
    { Protected declarations }
 
     procedure Loaded;override;
    //--------------------------------------------------------------------------
 
    // Fonctions pour intercepter les "HotKeys" sous Linux
    {$IFDEF LINUX}
      procedure WaitForXevent;
    {$ENDIF}
 
    // Fonctions pour intercepter les "HotKeys" sous Mac
    {$IFDEF DARWIN}
    {$ENDIF}
  public
    { Public declarations }
    {$IFDEF LINUX}
    Display: PDisplay;
    {$ENDIF}
 
    constructor Create(AOwner: TComponent);override;
    destructor Destroy; override;
 
    function CreateHotKey(Modifiers, Key: Word): Cardinal;
 
    function AddHotKey(HotKey: Cardinal): integer;
    function ChangeHotKey(Index: integer; NewHotKey: Cardinal): Integer;
    function RemoveHotKey(HotKey: Cardinal): Boolean;
    function RemoveHotKeyByIndex(Index: Integer): Boolean;
    procedure ClearHotKeys;
    function HotKeyValid(HotKey: Cardinal): Boolean;
    function HotKeyExist(Index: Integer): Integer;
    function FreeHotKey(Index:Integer): Boolean;
  published
    { Published declarations }
    property Active:Boolean read FActive write setActive default false;
    property HotKeys:TBZHotKeyList read FHotKeyList write FHotKeyList;
 
  //  property OnHotKey : TOnHotKeyEvent read FOnHotKey write FOnHotKey;
  end;
 
//==============================================================================
 
procedure SeparateHotKey(HotKey: Cardinal; var Modifiers, Key: Word);
 
//==============================================================================
 
procedure Register;
 
//==============================================================================
 
implementation
 
//==============================================================================
var
  //----------------------------------------------------------------------------
  // Variables pour intercepter les "HotKeys" sous Windows
  {$IFDEF WINDOWS}
    HWindow: HWND;
    WindowClassAtom: ATOM; // Renvoyer par RegisterWindowClass en cas de succes.
    WindowClassInfo: WNDCLASSEX; // Structure des infos d'une fenetre
  {$ENDIF}
 
//==============================================================================
 
{**-----------------------------------------------------------------------------
 * @Name        :  Register
 * @Description :  Enregistre notre composant dans l'IDE
 -----------------------------------------------------------------------------**}
procedure Register;
begin
  {$I ../../ressources/bz_hotkeymanager_icon.lrs}
  RegisterComponents('Beanz',[TBZHotKeyManager]);
end;
 
//==============================================================================
//==============================================================================
// Fonctions Internes
//==============================================================================
 
{$IFDEF WINDOWS}
{**-----------------------------------------------------------------------------
 * @Name        :  WinProc
 * @Description :  Handler pour Intercepter les message WM_HOTKEY
 *                 Nb: Vous pouvez intercepter d'autre messages comme ceux de la
 *                     souris, suffit d'ajouter des conditions au CASE ce qui
 *                     permettrai avec un peu d'ingéniosité de faire des HotKeys
 *                     genre : CRTL + ALT + G + SOURIS_BOUTON_GAUCHE
 -----------------------------------------------------------------------------**}
function WinProc(hw: HWND; uMsg: UINT; wp: WPARAM; lp: LPARAM): LRESULT;stdcall; export;
var
 obj : TBZHotKeyManager;
 idx:integer;
begin
  Result := 0;
  case uMsg of
    WM_HOTKEY :
    begin
        obj := TBZHotKeyManager(GetWindowLongPtr(HWindow,GWL_USERDATA));
        idx:=obj.HotKeyExist(Longint(wp));
        if (idx>-1) and (obj.Active) then obj.DoOnHotKey(idx);
    end
    else
      Result := DefWindowProc(hw, uMsg, wp, lp);
    end;
end;
{$ENDIF}
 
//==============================================================================
//==============================================================================
// 1. TBZHotKeyItem
//==============================================================================
constructor TBZHotKeyItem.Create(ACollection: TCollection);
begin
  if Assigned(ACollection) and (ACollection is TBZHotKeyList) then
    inherited Create(ACollection);
end;
 
//==============================================================================
//==============================================================================
// 2. TBZHotKeyList
//==============================================================================
 
//==== PRIVATE =================================================================
 
function TBZHotKeyList.GetItems(Index: integer): TBZHotKeyItem;
begin
  Result := TBZHotKeyItem(inherited Items[Index]);
end;
 
procedure TBZHotKeyList.SetItems(Index: integer; AValue: TBZHotKeyItem);
begin
  Items[Index].Assign(AValue);
end;
 
//==== PROTECTED ===============================================================
 
//==== PUBLIC ==================================================================
constructor TBZHotKeyList.Create;
begin
  inherited Create(TBZHotKeyItem);
end;
 
function TBZHotKeyList.Add: TBZHotKeyItem;
begin
  Result := inherited Add as TBZHotKeyItem;
end;
 
 
//==============================================================================
//==============================================================================
// 3. TBZXEventListener
//==============================================================================
 
//==== PRIVATE =================================================================
 
//==== PROTECTED ===============================================================
{$IFDEF LINUX}
{**-----------------------------------------------------------------------------
 * @Name        : Execute
 * @Description : Ecoute les evenements
 -----------------------------------------------------------------------------**}
procedure TBZXEventListener.Execute;
begin
  while  Terminated do
  begin
    if not Terminated then
    begin
      Synchronize(@FApplicationHotKeys.WaitForXevent)
    end;
    if Terminated then
      Exit;
  end;
end;
 
//==== PUBLIC ==================================================================
 
{**-----------------------------------------------------------------------------
 * @Name        : Create
 * @Description : Creation de notre thread "Ecouteur d'evenements"
 -----------------------------------------------------------------------------**}
constructor TBZXEventListener.Create(AAppHotKey:TBZHotKeyManager);
begin
  inherited Create(True);
  FApplicationHotKeys := AAppHotKey;
end;
{$ENDIF}
 
//==============================================================================
//==============================================================================
// 2. TBZHotKeyManager
//==============================================================================
 
//==== PRIVATE =================================================================
 
{$IFDEF WINDOWS}
{**-----------------------------------------------------------------------------
 * @Name        : CreateAppWindows
 * @Description : Creation d'une fenetre virtuelle avec notre Hook
 -----------------------------------------------------------------------------**}
function  TBZHotKeyManager.CreateAppWindow: boolean;
 
  function RegisterWindowClass: boolean;
  begin
    WindowClassInfo.cbSize := sizeof(WindowClassInfo);
    WindowClassInfo.Style := 0;
    WindowClassInfo.lpfnWndProc := @WinProc;
    WindowClassInfo.cbClsExtra := 0;
    WindowClassInfo.cbWndExtra := 0;
    WindowClassInfo.hInstance := HInstance;
    WindowClassInfo.hIcon := 0;
    WindowClassInfo.hCursor := 0;
    WindowClassInfo.hbrBackground := 0;
    WindowClassInfo.lpszMenuName := nil;
    WindowClassInfo.lpszClassName := PChar(WinClassName);
    WindowClassInfo.hIconSm := 0;
    WindowClassAtom := RegisterClassEx(WindowClassInfo);
    Result := WindowClassAtom <> 0;
  end;
 
begin
  Result := False;
  if not RegisterWindowClass then
  begin
     exit;
  end;
  HWindow := CreateWindowEx(WS_EX_NOACTIVATE or WS_EX_TRANSPARENT,
    PChar(WinClassName), PChar(WinClassName), Ws_popup or WS_CLIPSIBLINGS, 0,
    0, 0, 0, 0, 0, HInstance, nil);
  if HWindow <> 0 then
  begin
    ShowWindow(HWindow, SW_HIDE);
    SetWindowLongPtr(HWindow,GWL_USERDATA,PtrInt(Self));
    UpdateWindow(HWindow);
    Result := True;
    Exit;
  end;
end;
{$ENDIF}
 
{**-----------------------------------------------------------------------------
 * @Name        : DoRegisterHotKey
 * @Description : Ajoute un HotKey Global dans le systeme d'exploitation
 -----------------------------------------------------------------------------**}
function TBZHotKeyManager.DoRegisterHotKey(hk:cardinal):integer;
var
  Modifiers, Key: Word;
  id :integer;
  {$IFDEF LINUX}
  root :PGdkWindow;
  {$ENDIF}
begin
  result:=0;
  Modifiers:=0;
  Key:=0;
  SeparateHotKey(hk, Modifiers, Key);
 
  {$IFDEF WINDOWS}
  id := GlobalAddAtom(PChar(HotKeyAtomPrefix + IntToStr(hk)));
  RegisterHotKey(HWindow, Longint(id), Modifiers, Key);
  result:=id;
  {$ENDIF}
 
  {$IFDEF LINUX}
  root := gdk_get_default_root_window ();
  Display := GDK_WINDOW_XDISPLAY (root);
  gdk_error_trap_push;
  XGrabKey (Display, Key,Modifiers,gdk_x11_drawable_get_xid(root), 1,GrabModeAsync, GrabModeAsync);
  gdk_flush;
  Result := (gdk_error_trap_pop) = 0;
  {$ENDIF}
 
  {$IFDEF DARWIN}
  {$ENDIF}
end;
 
 
{**-----------------------------------------------------------------------------
 * @Name        : DoUnRegisterHotKey
 * @Description : Supprime un HotKey Global dans le systeme d'exploitation
 -----------------------------------------------------------------------------**}
function TBZHotKeyManager.DoUnRegisterHotKey(KeyIndex:integer):boolean;
{$IFDEF LINUX}
var
  root :PGdkWindow;
  Modifiers,Key:word;
  hk:Cardinal;
{$ENDIF}
begin
  {$IFDEF WINDOWS}
  result:=UnRegisterHotkey( HWindow, Longint(KeyIndex));
  GlobalDeleteAtom(KeyIndex);
  {$ENDIF}
 
  {$IFDEF LINUX}
  root := gdk_get_default_root_window ();
  Display := GDK_WINDOW_XDISPLAY (root);
  hk := Cardinal(FHotKeyList[HotKeyExist(KeyIndex)].HotKey);
  SeparateHotKey(hk, Modifiers, Key);
  XUngrabKey (Display, Key, Modifiers, gdk_x11_drawable_get_xid(root));
  {$ENDIF}
 
  {$IFDEF DARWIN}
  {$ENDIF}
end;
 
{**-----------------------------------------------------------------------------
 * @Name        : DoOnHotKey
 * @Description : Lance une action lorsque le HotKey est intercepté
 -----------------------------------------------------------------------------**}
procedure TBZHotKeyManager.DoOnHotKey(Index: Integer);
begin
  if Assigned(FHotKeyList[Index].OnExecute) then FHotKeyList[Index].OnExecute(self);
end;
 
{**-----------------------------------------------------------------------------
 * @Name        : SetActive
 * @Description : Active/Désactive l'interception des HotKeys
 *                Est utilisé par la version Linux et n'a aucun effet sous Windows
 -----------------------------------------------------------------------------**}
procedure TBZHotKeyManager.SetActive(Value: Boolean);
begin
  if FActive <> Value then
  begin
      FActive := Value;
      if not (csDesigning in ComponentState) then
      begin
        if FActive then
        begin
          {$IFDEF LINUX}
          FXEventListener.Suspended:=false;
          {$ENDIF}
        end
        else
        begin
          {$IFDEF LINUX}
          FXEventListener.Suspended:=true;
          {$ENDIF}
        end
      end;
  end;
end;
 
{**-----------------------------------------------------------------------------
 * @Name        : Loaded
 * @Description : Effectue une action lorsque le composant est chargé
 -----------------------------------------------------------------------------**}
procedure TBZHotKeyManager.Loaded;
var
  i,j:integer;
 // hk: TBZHotKeyItem;
  id:integer;
begin
  inherited;
  j:= FHotKeyList.Count;
  if J>0 then
  begin
    for i:= 0 to j-1 do
    begin
      //hk:=;
      id:=DoRegisterHotKey(Cardinal(FHotKeyList.Items[i].HotKey));
      if id>0 then
      begin
        FHotKeyList.Items[i].Index := id;
      end;
    end;
  end;
end;
 
//==== PROTECTED ===============================================================
 
{$IFDEF LINUX}
{**-----------------------------------------------------------------------------
 * @Name        : WaitForXevent
 * @Description : Attente d'interception des raccourcis sous Linux
 -----------------------------------------------------------------------------**}
procedure TBZHotKeyManager.WaitForXevent;
var
  event : XEvent;
  I,J,state:Integer;
  Modifiers,Key:word;
  xkey : XKeyEvent;
  hk  :TBZHotKeyItem;
begin
  //event := XEvent.Create();
  while (XPending(Display) > 0) do
  begin
   XNextEvent(Display, @event);
   if (event._type = KeyPress) then
   begin
     xkey := XKeyEvent(event.readField('xkey'));
     state := xkey.state and (ShiftMask or ControlMask or Mod1Mask or Mod4Mask);
     J:=FHotKeyList.Count-1;
     for I:=0 to J do
     begin
       hk:=FHotKeyList[I]//;^.HotKey;
       separateHotKey(Cardinal(hk.HotKey),Modifiers,Key);
       if (xkey.keycode = key ) and (state = Modifiers  ) then
       begin
         DoOnHotKey(I);
       end;
     end;
   end;
end;
{$ENDIF}
 
//==== PUBLIC ==================================================================
 
{**-----------------------------------------------------------------------------
 * @Name        : Create
 * @Description : Construction de notre composant
 -----------------------------------------------------------------------------**}
 
{**-----------------------------------------------------------------------------
* @Name        : Create
* @Description : Creation de notre composant
-----------------------------------------------------------------------------**}
constructor TBZHotKeyManager.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Self.SetSubComponent(True); // add this line if you want to put this class inside other and also be streamed
  FHotKeyList := TBZHotKeyList.Create;
 
  if not (csDesigning in ComponentState) then
    begin
      {$IFDEF WINDOWS}
      CreateAppWindow;
      {$ENDIF}
 
      {$IFDEF LINUX}
      FXEventListener := TBZXEventListener.Create(self);
      Display := XOpenDisplay(gdk_get_display);
      {$ENDIF}
 
      {$IFDEF DARWIN}
      {$ENDIF}
    end;
end;
 
{**-----------------------------------------------------------------------------
 * @Name        : Destroy
 * @Description : Destruction de notre composant
 -----------------------------------------------------------------------------**}
destructor TBZHotKeyManager.Destroy;
begin
  ClearHotKeys;
 
  {$IFDEF WINDOWS}
  DestroyWindow(HWindow);
  {$ENDIF}
 
  {$IFDEF LINUX}
  FXEventListener.Terminate;
  FXEventListener.WaitFor;
  FXEventListener.Free;
  XCloseDisplay(Display);
  {$ENDIF}
 
  {$IFDEF DARWIN}
  {$ENDIF}
 
  FHotKeyList.free;
  inherited Destroy;
end;
 
{**-----------------------------------------------------------------------------
 * @Name        :  CreateHotKey
 * @Description :  Creation du raccourcis clavier HotKey
 * @Exemple     :  CreateHotKey(MOD_CONTROL+MOD_ALT,VK_G); // CTRL+ALT+G
 -----------------------------------------------------------------------------**}
function TBZHotKeyManager.CreateHotKey(Modifiers, Key: Word): Cardinal;
const
  VK2_SHIFT   =  32;
  VK2_CONTROL =  64;
  VK2_ALT     = 128;
  VK2_WIN     = 256;
var
  hk: Cardinal;
begin
  hk := 0;
  if (Modifiers and MOD_ALT) <> 0 then
    Inc(hk, VK2_ALT);
  if (Modifiers and MOD_CONTROL) <> 0 then
    Inc(hk, VK2_CONTROL);
  if (Modifiers and MOD_SHIFT) <> 0 then
    Inc(hk, VK2_SHIFT);
  if (Modifiers and MOD_WIN) <> 0 then
    Inc(hk, VK2_WIN);
  hk := hk shl 8;
  Inc(hk, Key);
  Result := hk;
end;
 
{**-----------------------------------------------------------------------------
 * @Name        : AddHotKey
 * @Description : Ajoute un raccourcis clavier à intercepter dans la lsite
 -----------------------------------------------------------------------------**}
function TBZHotKeyManager.AddHotKey(HotKey: Cardinal): Integer;
var
  hk: TBZHotKeyItem;//PHotKey;
  id:integer;
begin
  // Creation d'un ID Unique
  id:=DoRegisterHotKey(HotKey);
  if id>0 then
  begin
    hk := FHotKeyList.Add;
    hk.HotKey := TShortCut(HotKey);
    hk.Index := id;
 
    Result :=FHotKeyList.Count-1;
  end
  else
  begin
    Result := -1;
  end;
end;
 
{**-----------------------------------------------------------------------------
 * @Name        :  ChangeHotKey
 * @Description :  Modifie un raccourcis dans la liste
 -----------------------------------------------------------------------------**}
function TBZHotKeyManager.ChangeHotKey(Index: Integer; NewHotKey: Cardinal): Integer;
var
  I,J: Integer;
  hk: TBZHotKeyItem;//PHotKey;
begin
  Result := 0;
  J:=FHotKeyList.Count -1;
  for I := 0 to J do
  begin
    hk := FHotKeyList[I];
    if hk.Index = Index then
    begin
      RemoveHotKeyByIndex(Index);
      Result := AddHotKey(NewHotKey);
      Exit;
    end;
  end;
end;
 
{**-----------------------------------------------------------------------------
 * @Name        : RemoveHotKey
 * @Description : Supprime un raccourci de la liste
 -----------------------------------------------------------------------------**}
function TBZHotKeyManager.RemoveHotKey(HotKey: Cardinal): Boolean;
var
  I,J: Integer;
  hk: TBZHotKeyItem;//PHotKey;
begin
  Result := False;
  J:= FHotKeyList.Count -1;
  for I := 0 to J do
  begin
    hk := FHotKeyList[I];
    if hk.HotKey = TShortCut(HotKey) then
    begin
      Result := FreeHotKey(I);
      FHotKeyList.Delete(I);
      Exit;
    end;
  end;
end;
 
{**-----------------------------------------------------------------------------
 * @Name        : RemoveHotKeyByIndex
 * @Description : Supprime un raccourci de la liste suivant Index
 -----------------------------------------------------------------------------**}
function TBZHotKeyManager.RemoveHotKeyByIndex(Index: Integer): Boolean;
var
  I,J: Integer;
  hk: TBZHotKeyItem;
begin
  Result := False;
  J:= FHotKeyList.Count -1;
  for I := 0 to J do
  begin
    hk := FHotKeyList[I];
    if hk.Index = Index then
    begin
      Result := FreeHotKey(I);
      FHotKeyList.Delete(I);
      Exit;
    end;
  end;
end;
 
{**-----------------------------------------------------------------------------
 * @Name        :  HotKeyValid
 * @Description :  Vérifie si un raccourci est deja inscrit dans le systeme
 *                 Renvoi Vrai si le HotKey peu être utilisé
 -----------------------------------------------------------------------------**}
function TBZHotKeyManager.HotKeyValid(HotKey: Cardinal): Boolean;
var
  M, K: Word;
  WasRegistered: Boolean;
  {$IFDEF WINDOWS}
  Atom: Word;
  {$ENDIF}
begin
  {$IFDEF WINDOWS}
  K:=0;
  M:=0;
  Atom := GlobalAddAtom(PChar(HotKeyAtomPrefix + IntToStr(HotKey)));
  SeparateHotKey(HotKey, M, K);
  WasRegistered := UnregisterHotKey(HWindow, Atom);
  if WasRegistered then
  begin
    RegisterHotKey(HWindow, Atom, M, K);
    Result := True;
  end
  else
  begin
    Result := RegisterHotKey(HWindow, Atom, M, K);
    if Result then
      UnregisterHotKey(HWindow, Atom);
  end;
  GlobalDeleteAtom(Atom);
  {$ENDIF}
 
  {$IFDEF LINUX}
  //@TODO : A Compléter
  result:=true;
  {$ENDIF}
 
  {$IFDEF DARWIN}
  {$ENDIF}
end;
 
{**-----------------------------------------------------------------------------
 * @Name        :  HotKeyExist
 * @Description :  Vérifie si un raccourci est deja inscrit dans le systeme
 *                 Renvoi Vrai si le HotKey peu être utilisé
 -----------------------------------------------------------------------------**}
function TBZHotKeyManager.HotKeyExist(Index: Integer): Integer;
 var
   I,J: Integer;
 begin
   Result := -1;
   J:=FHotKeyList.Count -1;
   for I := 0 to J do
     if FHotKeyList[I].Index = Index then
     begin
       Result :=I;
       Break;
     end;
 end;
 
{**-----------------------------------------------------------------------------
 * @Name        : ClearHotKeys
 * @Description : Efface la liste des raccourcis
 -----------------------------------------------------------------------------**}
procedure TBZHotKeyManager.ClearHotKeys;
var
  I,J: Integer;
//  hk: PHotKey;
begin
  J:=FHotKeyList.Count -1;
  for I := J downto 0 do
  begin
   // hk := PHotKey(FHotKeyList[I]);
    FreeHotKey(I);
    FHotKeyList.Delete(I);
  end;
//  FHotKeyList.Clear;
end;
 
{**-----------------------------------------------------------------------------
 * @Name        : FreeHotKey
 * @Description : Désinscrit et libère un raccourci
 -----------------------------------------------------------------------------**}
function TBZHotKeyManager.FreeHotKey(Index:Integer): Boolean;
begin
  Result := DoUnregisterHotKey(FHotKeyList[Index].Index);
 
  //if Result then
  //  Dispose(hk);
end;
 
//==============================================================================
//==============================================================================
 
//==============================================================================
// Fonctions Internes
//==============================================================================
 
{**-----------------------------------------------------------------------------
 * @Name        : SeparateHotKey
 * @Description : Separe les touches normal et les touches de controle du Hotkeys
 *                pour les utiliser avec RegisterHotKey
 -----------------------------------------------------------------------------**}
procedure SeparateHotKey(HotKey: Cardinal; var Modifiers, Key: Word);
{$IFDEF WINDOWS}
const
  VK2_SHIFT   =  32;
  VK2_CONTROL =  64;
  VK2_ALT     = 128;
  VK2_WIN     = 256;
{$ENDIF}
var
  Virtuals: Integer;
  V: Word;
  x: Word;
{$IFDEF LINUX}
  I:Integer;
 
  function correctModifiers(modifiers:word;flags:integer) :integer;
  var ret:word;
  begin
    ret:=modifiers;
    if ((flags and 1) <> 0) then ret := ret OR LockMask;
    if ((flags and 2) <> 0) then ret := ret OR Mod2Mask;
    if ((flags and 4) <> 0) then ret := ret OR Mod3Mask;
    if ((flags and 8) <> 0) then ret := ret OR Mod5Mask;
    result:=ret;
  end;
{$ENDIF}
begin
  Key := Byte(HotKey);
  x := HotKey shr 8;
  Virtuals := x;
 
  {$IFDEF WINDOWS}
  V := 0;
  if (Virtuals and VK2_WIN) <> 0 then Inc(V, MOD_WIN);
  if (Virtuals and VK2_ALT) <> 0 then Inc(V, MOD_ALT);
  if (Virtuals and VK2_CONTROL) <> 0 then Inc(V, MOD_CONTROL);
  if (Virtuals and VK2_SHIFT) <> 0 then Inc(V, MOD_SHIFT);
  Modifiers := V;
  {$ENDIF}
 
  {$IFDEF LINUX}
  V:=Virtuals;
  for i:=0 to 15 do
  begin
    V := correctModifiers(V, i);
  end;
  Modifiers := V;
  {$ENDIF}
 
  {$IFDEF DARWIN}
  {$ENDIF}
end;
 
//==============================================================================
//==============================================================================
 
//initialization
 
//------------------------------------------------------------------------------
//finalization
 
//==============================================================================
end.

Vous pouvez mainteant tester la demo Basic de celui-ci. En mettant la propriété "active" à TRUE

Si vous avez des pistes pour le TBZButton ou toutes autres suggestions pour l'ameliorer je suis preneur

Merci d'avance

A Bientot

**jurassic pork** · 19/10/2015, 23h56

hello,
tu es sûr que ta modif fonctionne BeanzMaster ? parce que moi sous windows 7 Lazarus 1.4.4 32 bits j'ai toujours pas d'action dans la démo Basic bz_HotKeyManager. J'ai bien mis active à TRUE dans le composant.
J'ai vérifié au débugger on passe bien dans la méthode Loaded mais toujours pas de raccourcis actifs

dans la fenêtre. Le fait que l'action soit faite avant l' Application.Run ne poserait-elle pas un problème ?

Une idée comme ça, tu pourrais crée une méthode reload sur ton composant qui rechargerait les raccourcis et qui pourrais être appelé à l'affichage de la fiche.

Ami calmant, J.P

**BeanzMaster** · 20/10/2015, 09h40

Salut JP bizarre je viens de retester et ca fonctionne nickel chez moi. Aussi bien sous lazarus 1.4.2 que sous CT 5.5.
Je pense que oui mais bon au cas ou as tu bien remplacer l'ancien fichier ?
Essayes de supprimer les anciens fichiers compilés du paquet et recompile pour voir.

Je joins un zip avec les fichiers compilés pour tester si ca marche la version 32Bits à été compilée avec Lazarus et la 64bits avec CT

Merci a bientot

hkmanagerdemoBin.zip

**BeanzMaster** · 20/10/2015, 11h09

Rebonjour à tous, après quelques heures de recherche et de test par rapport au TBZButton, les "ShortCuts" et l'interception des touches "enter", "espace" et la touche d'"accélération" fonctionnent mais seulement et seulement si le bouton à le focus.

Ce que je souhaiterai c'est en fait intercepter les touches provenant de la fenêtre parente.

J'ai consulté http://wiki.lazarus.freepascal.org/LCL_Key_Handling mais j'avoue ne pas bien comprendre le mécanisme.

J'ai essayé d'intercepter les "ShortCuts" dans le composant avec les procédures suivantes :
- WMKeyDown(var Message: TLMKeyDown);
- WMSysKeyDown(var Message: TLMKeyDown);
- WMChar(var Message: TLMChar);
- ControlKeyDown(var Key: Word; Shift: TShiftState);
- KeyDownBeforeInterface(var Key: Word; Shift: TShiftState);

rien à faire, il faut obligatoirement que le bouton ai le Focus.

Je sais que pour intercepter les touches provenant de la Form il faut soit :
- Mettre la propriété KeyPreview de la Form à true et gérér les touches avec les évênements OnKey de celle-ci.
- Soit passer par l'évênement OnMessage de la Form

Quelqu'un aurait-il des suggestions et ou des idées pour pouvoir intercepter les touches de la fenêtre directement dans le composant (sans passer par les évênements de la fenêtre si possible) ?

**jurassic pork** · 20/10/2015, 17h40

hello,
bon ben tes exécutables fonctionnent mais sniff

je n'ai toujours aucun raccourci qui marche quand je compile ton projet avec le fichier modifié.
Y a un hic soit dans la version de Lazarus, de l'O.S, de Fpc, des options de compilations. Y a t il un troisième larron qui pourrait essayer pour voir.
Beanzmaster, tu devrais refaire un zip avec tes sources actuelles pour qu'il n'y ait pas d'erreurs dans les fichiers à compiler.

Ami calmant, J.P

**BeanzMaster** · 23/10/2015, 19h32

Salut à tous,

Une petite mise à jour de mon petit paquet de composants

Les Nouveautés : 3 nouveaux composants non visuels

TBZAppHotKeyManager : Pour gérer les raccourcis au niveau de l'Application
TBZFormHotKeyManager : Pour gérer les raccourcis au niveau d'une Form
TBZFormEx : Pour ajouter des fonctions de magnétisme et de "snapping" aux fenêtres + 2 3 petites choses (cf Demo)

Les mises à jour :

TBZHotKeyManager : fonctionne parfaitement sous Windows (cf Demos)
TBZThreadTimer : j'ai ajouté une petite propriété "Accurate" qui fait que le Timer ne se synchronise pas avec lui même (augmente sa rapidité d’exécution)
TBZButton : à 90% fonctionnel.
- les raccourcis globaux fonctionnent maintenant (grâce à TBZFormHotKeyManager)
- Ajout la possibilité de dessiner des flèches
- Ajout du Focus
- Possibilité d'utiliser un seul glyph pour tous les états du bouton
- Gestion et positionnement du popupmenu

Les Bugs connus :
Dans TBZButton

Le focus sur un bouton avec Shape=bsRoundRect + Rounding=rsSquared provoque une exception
L'affichage des bordures est encore à améliorer
le calcul de la position et dimension des différents éléments est à corriger

Il reste encore à faire pas mal de petites choses, à incorporer, à améliorer (cf commentaires dans la source)
A ce stade il me manque plus que d'ajouter la possibilité de les grouper (comme TSpeedButton) et les utiliser comme des bouton à bascule afin que je puisse les utiliser dans mon projet.

Voila c'est un près tout. Vous trouverez dans l'archive sous forme de fichier XML les options de compilations que j'utilise.

J'attend vos commentaires, et toutes suggestions. Si vous faite des modifications n'hésiter pas à me les faire parvenir.

PS: Les exécutables des démos compilés par vos soins, se retrouveront dans le sous-dossier "BIN" de chacun d'entre eux. Et si jamais je ferai une petite archive avec les démos compilées

pl_Beanz.7z

**BeanzMaster** · 24/10/2015, 10h50

Salut à tous,

Hier tout content de moi de mettre une mise à jour, ce matin j'ouvre de nouveau les démos pour quelques test et la paf c'est la cata les événements OnClick des TBZButton ont disparu, le TBZFormEx ne fonctionne plus correctement ainsi que le TBZHotkeyManager. Bref après un peu de debug. J'ai trouvé ce qui clochait dans ces 3 composants.

1 - Dans le TBZButton, il semblerait que lorsque l'on utilise une procédure pour définir un événement hérité (ici OnClick) celui-ci n'est pas sauvegarder correctement dans le projet
2 - Dans TBZHotKeyManager dans la liste des raccourcis il fallait que la propriété Index soit en lecture seule sinon elle est enregistrée quelque part dans les fichiers compilés. Ce qui faisait qu'a une 2eme compilation du projet les raccourcis ne fonctionnaient plus
3 - Dans le TBZformEx, quelques petits bugs oubliés. J'ai voulu être trop pressé. De même que la propriété Magneticfield doit être au mini à 64 car sinon le snapping des fenêtre en haut et bas ne se fait pas correctement
Sous Windows 7. J'ai remarqué que la position Left et Top correspondent aux positions de la fenêtre mais sans les bordures et la barre de titre. Ces positions sont relative au contenu de la form.

Voilà la mise à jour

pl_Beanz.7z

**jurassic pork** · 25/10/2015, 23h12

hello,
avec ta nouvelle mise à jour, les raccourcis maintenant fonctionnent dans la démo gestionnaire de raccourcis basic

Ami calmant, J.P

**BeanzMaster** · 26/10/2015, 09h25

Envoyé par jurassic pork

hello,
avec ta nouvelle mise à jour, les raccourcis maintenant fonctionnent dans la démo gestionnaire de raccourcis basic

Ami calmant, J.P

Cool super ! et sinon des autres composants vous en pensez quoi ? Allez ne soyez pas timide

**BeanzMaster** · 08/11/2015, 12h10

Salut à tous apres de grosses prises de tête pour gérer la transparence dans les composants visuels (que ce soit à partir de TCustomControl ou TGraphicControl) j'abandonne l'idée d'utilisé les fonctions native de FPC et Lazarus. Il ya trop de bug lors de manipulations avec des Bitmaps et du canvas (perte d'informations des couleurs, function copyRect, Draw, CopyBrush trop buggées). Un exemple tout bête j'ai utilisés LazIntImage pour créer un petit effet d'antialiasing (accès scanline) ben si c'est la dernière fonction utilisée c'est bon mais par contre si après on veut manipuler le canvas du bitmap en retour après, les couleurs du canvas ne s'affichent plus, tout est dessiné en Blanc. Ou encore Si on utilisent 2 Bitmaps temporaires et que l'on utilise copyRect, Draw.. ca ne fonctionne plus correctement. Une seule chose fonctionne correctement il faut obligatoirement passé par le Canvas du control pour dessiner et la pas de soucis de transparence ou autres.
Bref j'abandonne et je vais me tourner vers l'utilisation de la librairie BGRABitmap. De plus l'approche des BGRAControls est très similaire à la mienne.

Pour tester voila le code pour afficher un label. J'ai laissé les commentaires pour que vous puissiez voir tout ce que j'ai tenté. Donc soit il y a vraiment des erreurs dans mon code, soit ????????

bz_Graphics

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
 
unit bz_graphics;
 
{$mode objfpc}{$H+}
 
interface
//==============================================================================
 
uses
  Classes, SysUtils, Controls, Graphics, GraphMath, Math,
  LCLType, LCLIntf, Dialogs,FPImage, GraphType, IntfGraphics,
  bz_types;
 
//==============================================================================
 
function LightenColor(AColor:TColor;Factor:Byte):TColor;
function DarkenColor(AColor:TColor;Factor:Byte):TColor;
 
procedure BitmapCopy(SrcBmp:TBitmap;DstBmp:TBitmap;StartX,StartY,DestX,DestY:integer;Width,Height:Integer);
 
procedure DoAntialias(ABmp:TBitmap);
procedure DoCanvasAntiAlias(ACanvas:TCanvas;ARect:TRect);
 
procedure DoDrawGradient(ABmp:TBitmap; ARect: TRect; Color1, Color2: TColor; GradientType : TBZGradientType; Region: HRGN);
//procedure DoDrawGradient2(ACanvas:TCanvas; ARect: TRect; Color1, Color2: TColor; GradientType : TBZGradientType; Region: HRGN);
 
procedure DoDrawBackground(ABmp:TBitmap;ARect:TRect;AShape:TBZShapeType;ARoundingType : TBZRoundingType; ARoundX, ARoundY: Integer; AIsGradient:Boolean;AGradientType:TBZGradientType;AColor1,AColor2:TColor;Var PolyArray:PPoint; Var APolyCount:Byte; Var Region : HRGN);
procedure DoDrawBorders(ABmp:TBitmap;ARect:TRect;AShape:TBZShapeType;ARoundingType : TBZRoundingType; ARoundX, ARoundY: Integer; ABorders : TBZBorders;ABorderWidth:Integer; ABordersColor : TBZBordersColor;ABorderStyle:TPenStyle;APolyArray:PPoint;APolyCount:Byte);
 
procedure DoDrawText(ABmp:TBitmap;ARect:TRect; AText:String; AStyle : TBZTextStyle; AHorizontalLayout:TBZHorizontalLayout; AVerticalLayout:TBZVerticalLayout;AWordWrap, AEndEllipsis, ASingleLine, AShowPrefix, AClipping:Boolean);
procedure DoDrawCanvasText(ACanvas:TCanvas;ARect:TRect; AText:String; AStyle : TBZTextStyle; AHorizontalLayout:TBZHorizontalLayout; AVerticalLayout:TBZVerticalLayout;AWordWrap, AEndEllipsis, ASingleLine, AShowPrefix, AClipping:Boolean);
 
procedure DoDrawGlyph(ABmp:TBitmap; AGlyph:TPicture;ARect:TRect;AHorizontalLayout:TBZHorizontalLayout;AVerticalLayout:TBZVerticalLayout;AAdjustH, AAdjustV:Integer;ATransp:Boolean);
procedure DoDrawArrow(ABmp:TBitmap; ARect: TRect; ADirection: TBZDirection; AColor, ABorderColor: TColor;AABorderWidth:Integer;AAdjustH, AAdjustV:Integer);
 
//==============================================================================
 
implementation
 
 
type
  TRGBTripleArray = array[0..32767] of TRGBTriple;
  PRGBTripleArray = ^TRGBTripleArray;
//==============================================================================
//==============================================================================
// Fonctions Internes
//==============================================================================
const
  BitMaskTable: Array[0..31] of LongWord =
    ($00000001, $00000002, $00000004, $00000008,
     $00000010, $00000020, $00000040, $00000080,
     $00000100, $00000200, $00000400, $00000800,
     $00001000, $00002000, $00004000, $00008000,
     $00010000, $00020000, $00040000, $00080000,
     $00100000, $00200000, $00400000, $00800000,
     $01000000, $02000000, $04000000, $08000000,
     $10000000, $20000000, $40000000, $80000000);
 
function ReverseBits(Value: LongWord): LongWord;
var I : Byte;
begin
  Result := 0;
  For I := 0 to 31 do
    if Value and BitMaskTable[I] <> 0 then
      Result := Result or BitMaskTable[31 - I];
end;
 
 
procedure BitmapCopy(SrcBmp:TBitmap;DstBmp:TBitmap;StartX,StartY,DestX,DestY:integer;Width,Height:Integer);
var
  x,y,dx,dy,ix,iy,w,h:integer;
  c: TFPColor;
begin
 dx:=DestX;
 dy:=DestY;
 w:=StartX+Width-1;
 h:=StartY+Height-1;
 ix:=0;
 iy:=0;
 For y:=StartY to  h do
 begin
   ix:=0;
   For x:=StartX to w do
   begin
     c:=SrcBmp.Canvas.Colors[x,y];
     DstBmp.Canvas.Colors[dx+ix,dy+iy]:=c;
     inc(ix);
   end;
   inc(iy);
 end;
end;
 
{**-----------------------------------------------------------------------------
 * @Name        : LightenColor
 * @Description : Eclaircir une couleur en fonction du facteur en pourcentage
 -----------------------------------------------------------------------------**}
function LightenColor(AColor:TColor;Factor:Byte):TColor;
var r,g,b,d : Integer;
begin
 
 r := GetRValue(AColor);
 g := GetGValue(AColor);
 b := GetBValue(AColor);
 
 d:=round(r*factor / 100);
 r:=min(r+d,255);
 d:=round(g*factor / 100);
 g:=min(g+d,255);
 d:=round(b*factor / 100);
 b:=min(b+d,255);
 
 result := RGB(r,g,b);
end;
 
{**-----------------------------------------------------------------------------
 * @Name        : DarkenColor
 * @Description : Assombrir une couleur en fonction du facteur en pourcentage
 -----------------------------------------------------------------------------**}
function DarkenColor(AColor:TColor;Factor:Byte):TColor;
var r,g,b,d  : Integer;
begin
  r := GetRValue(AColor);
  g := GetGValue(AColor);
  b := GetBValue(AColor);
 
  //d:= (r+g+b) div 3;
  //d:=round(d*factor / 100);
  d:=round(r*factor / 100);
  r:=max(r-d,0);
  d:=round(g*factor / 100);
  g:=max(g-d,0);
  d:=round(b*factor / 100);
  b:=max(b-d,0);
 
  result := RGB(r,g,b);
end;
 
 
function GetBGR(C: TColorRef): Cardinal;
Begin
{$ASMMODE intel}
asm
        MOV     ECX,EAX         // this function swaps R and B bytes in ABGR
        SHR     EAX,16
        XCHG    AL,CL
        MOV     AH,$FF          // and writes $FF into A component }
        SHL     EAX,16
        MOV     AX,CX
end;
end;
 
 
function ColorRefToRGB(C: TColorRef): Cardinal;
Begin
{$ASMMODE intel}
asm
    bswap eax
    shr eax, 8
    and eax, $00FFFFFF
end;
end;
 
function ColorRefToARGB(C: TColorRef): Cardinal;
Begin
{$ASMMODE intel}
asm
    bswap eax
    shr eax, 8
    or eax, $FF000000
end;
 
end;
 
procedure LineMapH(x1,ys,x2,xd,yd,ll:integer;ASrcBmp,ADstBmp:TBitmap);
Var
  i,v1,x,l :integer;
  col : TFPColor;
  maxWidth : integer;
begin
  maxWidth := ADstBmp.Width-1;
  v1:= (x2-x1) div ll;
  x := x1;
 
  // Clipping droit
  if (xd+ll)>maxWidth then l:=ll-(xd+ll-maxWidth);
 
  for i:=0 to l do
  begin
    x:=x+v1;
    if (xd>=0) then  // Clipping gauche
    begin
      col := ASrcBmp.Canvas.Colors[x,ys];
      ADstBmp.Canvas.Colors[xd,yd]:=col;
    end;
    inc(xd);
  end;
end;
 
procedure FloodFillTexture(ADstBmp,ATexBmp:TBitmap);
var
  maxTexWidth, maxTexHeight, maxWidth, maxHeight : integer;
  y,yt : integer;
begin
  maxTexWidth  := ATexBmp.Width - 1;
  maxTexHeight := ATexBmp.Height - 1;
  maxWidth     := ADstBmp.Width - 1;
  maxHeight    := ADstBmp.Height -1;
 
  yt := 0;
  for y:=0 to maxHeight do
  begin
    if (yt>maxTexHeight) then yt:=0;
    LineMapH(0,yt,maxTexWidth,0,y,maxWidth,ATexBmp,ADstBmp);
  end;
end;
 
//procedure LineMap(x1,y1,x2,y2,xd,yd,ll:integer;ASrcBmp,ADstBmp:TBitmap);
//begin
//
//end;
 
{**-----------------------------------------------------------------------------
 * @Name        : DoDrawGradient
 * @Description : Dessine un dégradé entre Color1 and Color2 dans un canvas et suivant la region si elle est définie
 -----------------------------------------------------------------------------**}
procedure DoDrawGradient(ABmp:TBitmap; ARect: TRect; Color1, Color2: TColor; GradientType : TBZGradientType; Region: HRGN);
var
  y, x, MaxDist, C1, C2 : integer;
  Dep : array[0..2] of integer;
  Dif : array[0..2] of Double;
  Coef : Double;
 
begin
  // Si color1 = color2 = clNone alors le fond sera transparent
 // if Color1 = clNone then Color1:=clFuchsia;
 // if Color2 = clNone then Color2:=clFuchsia;
 
  if Color1 = Color2  then begin
    ABmp.Canvas.Brush.Color := Color1;
    if Region > 0 then
      FillRgn(ABmp.Canvas.Handle, Region, ABmp.Canvas.Brush.Reference.Handle)
    else
      ABmp.Canvas.FillRect(ARect);
    Exit;
  end;
 
  C1 := ColorToRGB(Color1);
  C2 := ColorToRGB(Color2);
 
  case GradientType of
    gtVertical : MaxDist := ARect.Bottom - ARect.Top;
 
    gtHorizontal : MaxDist := ARect.Right - ARect.Left;
 
    gtFromTopLeft,
    gtFromTopRight: MaxDist := (Round(Sqrt( Sqr(ARect.Right - ARect.Left)
                              + Sqr(ARect.Bottom - ARect.Top)))
                              - ARect.Left);
    gtRadial: MaxDist := (Round(Sqrt( Sqr(ARect.Right - ARect.Left)
                              + Sqr(ARect.Bottom - ARect.Top)))
                              - ARect.Left) div 2;
    gtDoubleHorz: MaxDist :=  (ARect.Right - ARect.Left) div 2;
    gtDoubleVert: MaxDist :=  (ARect.Bottom - ARect.Top) div 2;
  end;
 
  if MaxDist = 0 then MaxDist:=1;
 
  Dep[0] := GetRValue(C1);
  Dep[1] := GetGValue(C1);
  Dep[2] := GetBValue(C1);
 
  Dif[0] := (GetRValue(C2) - Dep[0]) / MaxDist;
  Dif[1] := (GetGValue(C2) - Dep[1]) / MaxDist;
  Dif[2] := (GetBValue(C2) - Dep[2]) / MaxDist;
 
  if Dif[0] > 255 then Dif[0] := 255;
  if Dif[1] > 255 then Dif[1] := 255;
  if Dif[2] > 255 then Dif[2] := 255;
 
  Abmp.BeginUpdate(True);
  for y:= ARect.Top to ARect.Bottom -1 do
  begin
    for x := ARect.Left to ARect.Right - 1 do
    begin
      case GradientType of
          gtHorizontal : Coef := x - ARect.Left;
          gtVertical :   Coef := y - ARect.Top;
          gtFromTopLeft :Coef := Sqrt(Sqr(x - ARect.Left) + Sqr(y - ARect.Top));
          gtFromTopRight:Coef := Sqrt(Sqr(ARect.Right - x) + Sqr(y - ARect.Top));
          gtRadial: Coef := Sqrt(Sqr(((ARect.Right - ARect.Left) shr 1) - x) + Sqr(y - ((ARect.Bottom - ARect.Top) shr 1)));
          gtDoubleHorz: Coef := Abs(x - MaxDist - ARect.Left);
          gtDoubleVert: Coef := Abs(y - MaxDist - ARect.Top);
      end;
 
      if (Region > 0) then
      begin
        if PtInRegion(Region, x, y) then
        begin
 
         ABmp.Canvas.Pixels[x,y] :=  RGB(Byte(Round(Dep[0] + (Dif[0] * Coef))),
                                       Byte(Round(Dep[1] + (Dif[1] * Coef))),
                                       Byte(Round(Dep[2] + (Dif[2] * Coef))));
        end
        else
        begin
          ABmp.Canvas.Pixels[x,y] :=clNone;//clFuchsia;
        end;
      end
      else
      begin
        ABmp.Canvas.Pixels[x,y] :=  RGB(Byte(Round(Dep[0] + (Dif[0] * Coef))),
                                          Byte(Round(Dep[1] + (Dif[1] * Coef))),
                                          Byte(Round(Dep[2] + (Dif[2] * Coef))));
      end;
    end;
  end;
  Abmp.EndUpdate(False);
end;
 
// Fonctionne mais très lent
procedure DoCanvasAntiAlias(ACanvas:TCanvas;ARect:TRect);
Var
  yDest, xDest  : integer;
  iWidth,iHeight : Integer;
  R, G, B,A : Byte;
 
  R2, G2, B2 : Byte;
  R3, G3, B3 : Byte;
  R4, G4, B4 : Byte;
  R5, G5, B5 : Byte;
  C1,C2,C3,C4,CD : TFPColor;
begin
  iWidth := ARect.Right - ARect.Left;
  iHeight := ARect.Bottom - ARect.Top;
  ACanvas.Lock;
  For yDest := ARect.Top+1 to iHeight-2 do
  begin
    For xDest := ARect.Left+1 to iWidth-2 do
    begin
      C1:=ACanvas.Colors[xDest-1,YDest];
      C2:=ACanvas.Colors[xDest+1,YDest];
      C3:=ACanvas.Colors[xDest,YDest-1];
      C4:=ACanvas.Colors[xDest,YDest+1];
      CD.Red := (C1.Red+C2.Red+C3.Red+C4.Red) div 4;
      CD.Blue := (C1.Blue+C2.Blue+C3.Blue+C4.Blue) div 4;
      CD.Green := (C1.Green+C2.Green+C3.Green+C4.Green) div 4;
      CD.Alpha := (C1.Alpha+C2.Alpha+C3.Alpha+C4.Alpha) div 4;
      ACanvas.Colors[xDest,yDest] := CD;
    end;
  end;
  ACanvas.UnLock;
end;
 
// Antialiasing d'un bitmap (avec LazIntfImage)
procedure DoAntialias(ABmp:TBitmap);
var
  RowDest : Pointer;
  RowSrc,RowSrcA,RowSrcB  : Pointer;
 
  iWidth:Integer;
  //TempIntfImg,
  ImgDest,
  ImgSrc: TLazIntfImage;
  //ImgFormatDescription: TRawImageDescription;
 
  yDest, xDest  : integer;
 
  //tmpBmp : TBitmap;
 
  R, G, B,A : Byte;
 
  R2, G2, B2 : Byte;
  R3, G3, B3 : Byte;
  R4, G4, B4 : Byte;
  R5, G5, B5 : Byte;
 
  ImgHandle,ImgMaskHandle: HBitmap;
begin
 
  ImgDest:=TLazIntfImage.Create(0,0);
  //ImgFormatDescription.Init_BPP32_R8G8B8A8_BIO_TTB(ABmp.Width,ABmp.Height); --> Ok format RGBA
 
  ImgDest.DataDescription:= ABmp.RawImage.Description; //ImgFormatDescription; --> Ok format BGRA
 
  ImgSrc:=ABmp.CreateIntfImage;
  iWidth := ABmp.Width;
 
  for yDest:= 1 to ABmp.Height -2 do
    begin
      rowDest := ImgDest.GetDataLineStart(yDest);
      rowSrc := ImgSrc.GetDataLineStart(yDest);
      rowSrcA := ImgSrc.GetDataLineStart(yDest-1);
      rowSrcB := ImgSrc.GetDataLineStart(yDest+1);
      for xDest :=1 to ABmp.Width-2 do
      begin
       // A:= PByte(rowSrc)[(xDest mod iWidth)*4+3];
 
        B2 := PByte(rowSrcA)[(xDest mod iWidth)*4];
        G2 := PByte(rowSrcA)[(xDest mod iWidth)*4+1];
        R2 := PByte(rowSrcA)[(xDest mod iWidth)*4+2];
 
        B3 := PByte(rowSrcB)[(xDest mod iWidth)*4];
        G3 := PByte(rowSrcB)[(xDest mod iWidth)*4+1];
        R3 := PByte(rowSrcB)[(xDest mod iWidth)*4+2];
 
        B4 := PByte(rowSrc)[((xDest-1) mod iWidth)*4];
        G4 := PByte(rowSrc)[((xDest-1) mod iWidth)*4+1];
        R4 := PByte(rowSrc)[((xDest-1) mod iWidth)*4+2];
 
        B5 := PByte(rowSrc)[((xDest+1) mod iWidth)*4];
        G5 := PByte(rowSrc)[((xDest+1) mod iWidth)*4+1];
        R5 := PByte(rowSrc)[((xDest+1) mod iWidth)*4+2];
 
        R := (R2+R3+R4+R5) div 4;
        G := (G2+G3+G4+G5) div 4;
        B := (B2+B3+B4+B5) div 4;
 
        // On met le tout dans l'image de destination
 
        // Le format des Bitmaps est BGRA
        PByte(rowDest)[(xDest mod iWidth)*4]  := B;
        PByte(rowDest)[(xDest mod iWidth)*4+1]:= G;
        PByte(rowDest)[(xDest mod iWidth)*4+2]:= R;
        PByte(rowDest)[(xDest mod iWidth)*4+3]:= 255;
      end;
    end;
 
  //TempIntfImg:= ABmp.CreateIntfImage; // Normalement le même que le Bitmap
 
  // convert the content from the very specific to the current format
  //TempIntfImg.CopyPixels(ImgDest); --> Ok
 
  // Meme si on Passe par un bitmap temporaire  et on le copy via Canvas
  // si ce n'est pas le dernier Traitement à effectuer.
  // Et si on utilise le canvas apres, les informations des couleurs
  // ne sont pas prisent en compte et s'affiche en Blanc  ????
  // A la place du canvas faudrait il passer par les fonctions utilisant un DC ???
 
  //TmpBmp := TBitmap.Create;
  //TmpBmp.SetSize(ABmp.Width,ABmp.Height);
  //TmpBmp.LoadFromIntfImage(TempIntfImg);
  //ABmp.Canvas.Draw(0,0,TmpBmp); --> Ok
 
  //ImgDest.CreateBitmaps(ImgHandle,ImgMaskHandle,False);
  //ABmp.Handle:=ImgHandle;
  //ABmp.MaskHandle:=ImgMaskHandle;  --> Ok
 
  ABmp.LoadFromIntfImage(ImgDest); //--> Ok
 
 
  ImgDest.Free;
  ImgSrc.Free;
  //TempIntfImg.Free;
  //TmpBmp.Free;
end;
 
//{**-----------------------------------------------------------------------------
// * @Name        : DoDrawGradient
// * @Description : Dessine un dégradé entre Color1 and Color2 dans un canvas et suivant la region si elle est définie
// -----------------------------------------------------------------------------**}
procedure DoDrawGradient2(ABmp:TBitmap; ARect: TRect; Color1, Color2: TColor; GradientType : TBZGradientType; Region: HRGN);
var
  y, x, MaxDist, C1, C2,C3 : integer;
  Dep : array[0..2] of integer;
  Dif : array[0..2] of Double;
  Coef : Double;
  //rowDest : PTRGBAQuad;
  RowDest : Pointer;//PRGBTripleArray;
  iWidth:Integer;
  TempIntfImg,ScanLineImage: TLazIntfImage;
  ImgFormatDescription: TRawImageDescription;
  TmpBmp : TBitmap;
 
begin
 
  C3 := colorToRGB(clNone);
 
  iWidth:=ABmp.Width;
 
  ScanLineImage:=TLazIntfImage.Create(0,0);
  ImgFormatDescription.Init_BPP32_R8G8B8A8_BIO_TTB(ABmp.Width,ABmp.Height);
  ScanLineImage.DataDescription:=ImgFormatDescription;
 
  if Color1 = Color2  then begin
    ABmp.Canvas.Brush.Color := Color1;
    if Region > 0 then
      FillRgn(ABmp.Canvas.Handle, Region, ABmp.Canvas.Brush.Reference.Handle)
    else
      ABmp.Canvas.FillRect(ARect);
    Exit;
  end;
 
  C1 := ColorToRGB(Color1);
  C2 := ColorToRGB(Color2);
 
  case GradientType of
    gtVertical : MaxDist := ARect.Bottom - ARect.Top;
 
    gtHorizontal : MaxDist := ARect.Right - ARect.Left;
 
    gtFromTopLeft,
    gtFromTopRight: MaxDist := (Round(Sqrt( Sqr(ARect.Right - ARect.Left)
                              + Sqr(ARect.Bottom - ARect.Top)))
                              - ARect.Left);
    gtRadial: MaxDist := (Round(Sqrt( Sqr(ARect.Right - ARect.Left)
                              + Sqr(ARect.Bottom - ARect.Top)))
                              - ARect.Left) div 2;
    gtDoubleHorz: MaxDist :=  (ARect.Right - ARect.Left) div 2;
    gtDoubleVert: MaxDist :=  (ARect.Bottom - ARect.Top) div 2;
  end;
 
  if MaxDist = 0 then MaxDist:=1;
 
  Dep[0] := GetRValue(C1);
  Dep[1] := GetGValue(C1);
  Dep[2] := GetBValue(C1);
 
  Dif[0] := (GetRValue(C2) - Dep[0]) / MaxDist;
  Dif[1] := (GetGValue(C2) - Dep[1]) / MaxDist;
  Dif[2] := (GetBValue(C2) - Dep[2]) / MaxDist;
 
  if Dif[0] > 255 then Dif[0] := 255;
  if Dif[1] > 255 then Dif[1] := 255;
  if Dif[2] > 255 then Dif[2] := 255;
 
 // SetLength( rowDest,ABmp.Height);
 // getmem(RowDest,(ARect.Right-ARect.Left)*sizeof(TRGBAQuad));
  for y:= ARect.Top to ARect.Bottom-1 do
  begin
    rowDest := ScanLineImage.GetDataLineStart(y);
    for x := ARect.Left to ARect.Right-1 do
    begin
      case GradientType of
          gtHorizontal : Coef := x - ARect.Left;
          gtVertical :   Coef := y - ARect.Top;
          gtFromTopLeft :Coef := Sqrt(Sqr(x - ARect.Left) + Sqr(y - ARect.Top));
          gtFromTopRight:Coef := Sqrt(Sqr(ARect.Right - x) + Sqr(y - ARect.Top));
          gtRadial: Coef := Sqrt(Sqr(((ARect.Right - ARect.Left) shr 1) - x) + Sqr(y - ((ARect.Bottom - ARect.Top) shr 1)));
          gtDoubleHorz: Coef := Abs(x - MaxDist - ARect.Left);
          gtDoubleVert: Coef := Abs(y - MaxDist - ARect.Top);
      end;
 
      if (Region > 0) then
      begin
        if PtInRegion(Region, x, y) then
        begin
          //CurColor.red:=Byte(Round(Dep[0] + (Dif[0] * Coef)));;
          //CurColor.green:=Byte(Round(Dep[1] + (Dif[1] * Coef)));
          //CurColor.blue:=Byte(Round(Dep[2] + (Dif[2] * Coef)));
          ////CurColor.alpha:= 0;
          //TempIntfImg.Colors[x,y]:=CurColor;
          PByte(RowDest)[(x mod iWidth)*4]   := Byte(Round(Dep[0] + (Dif[0] * Coef))); // Red;
          PByte(RowDest)[(x mod iWidth)*4+1] := Byte(Round(Dep[1] + (Dif[1] * Coef))); // Green;
          PByte(RowDest)[(x mod iWidth)*4+2] := Byte(Round(Dep[2] + (Dif[2] * Coef)));   // Blue;
          PByte(RowDest)[(x mod iWidth)*4+3] := 255; // Alpha
 
          //RowDest^[x].rgbtRed := Byte(Round(Dep[0] + (Dif[0] * Coef)));
          //RowDest^[x].rgbtGreen := Byte(Round(Dep[1] + (Dif[1] * Coef)));
          //RowDest^[x].rgbtBlue := Byte(Round(Dep[2] + (Dif[2] * Coef)));
//          RowDest^[x].Alpha := 255;
        end
        else
        begin
          //RowDest^[x].rgbtRed := GetRValue(C3);
          //RowDest^[x].rgbtGreen := GetGValue(C3);
          //RowDest^[x].rgbtBlue := GetBValue(C3);
          PByte(RowDest)[(x mod iWidth)*4]   := GetRValue(C3);  // Blue;
          PByte(RowDest)[(x mod iWidth)*4+1] := GetGValue(C3); // Green;
          PByte(RowDest)[(x mod iWidth)*4+2] := GetBValue(C3); // Red;
          PByte(RowDest)[(x mod iWidth)*4+3] := 255; // Alpha
          //RowDest^[x].Alpha := 255;
        end;
      end
      else
      begin
        //RowDest^[x].rgbtRed := Byte(Round(Dep[0] + (Dif[0] * Coef)));
        //RowDest^[x].rgbtGreen := Byte(Round(Dep[1] + (Dif[1] * Coef)));
        //RowDest^[x].rgbtBlue := Byte(Round(Dep[2] + (Dif[2] * Coef)));
        PByte(RowDest)[(x mod iWidth)*4]   := Byte(Round(Dep[0] + (Dif[0] * Coef))); // Red;
        PByte(RowDest)[(x mod iWidth)*4+1] := Byte(Round(Dep[1] + (Dif[1] * Coef))); // Green;
        PByte(RowDest)[(x mod iWidth)*4+2] := Byte(Round(Dep[2] + (Dif[2] * Coef)));   // Blue;
        PByte(RowDest)[(x mod iWidth)*4+3] := 255; // Alpha
        //RowDest[y][x].Alpha := 255;
 
      end;
    end;
  end;
 // freemem(RowDest);
  //TempBitmap.LoadFromIntfImage(TempIntfImg);
  TmpBmp := TBitmap.Create;
  TmpBmp.Width:=ABmp.Width;
  TmpBmp.Height:=ABmp.Height;
 
  TempIntfImg:= TmpBmp.CreateIntfImage;
  // convert the content from the very specific to the current format
  TempIntfImg.CopyPixels(ScanLineImage);
  TmpBmp.LoadFromIntfImage(TempIntfImg);
  ABmp.Canvas.Draw(0,0,TmpBmp);
 
  TmpBmp.free;
  ScanLineImage.Free;
  TempIntfImg.Free;
end;
{**-----------------------------------------------------------------------------
 * @Name        : DoDrawBackground
 * @Description : Dessine le fond
 *                - Renvois un Tableau de Points et sont nombre et renvois une Region au besoin
 -----------------------------------------------------------------------------**}
procedure DoDrawBackground(ABmp:TBitmap;ARect:TRect;AShape:TBZShapeType;ARoundingType : TBZRoundingType; ARoundX, ARoundY: Integer; AIsGradient:Boolean;AGradientType:TBZGradientType;AColor1,AColor2:TColor;Var PolyArray:PPoint; Var APolyCount:Byte; Var Region : HRGN);
var
  x1,y1,x2,y2 : Integer;
  nbPoints : byte;
  bRoundX, bRoundY : Integer;
  wWidth, wHeight : Integer;
  wMiddleWidth, wMiddleHeight : Integer;
  PolyRegion : PPoint;
begin
  wWidth  := ARect.Right - ARect.Left;
  wHeight := ARect.Bottom - ARect.Top;
  wMiddleWidth  := wWidth div 2;
  wMiddleHeight := wHeight div 2;
 
  bRoundX:=ARoundX;
  bRoundY:=ARoundY;
 
  Case AShape of
    stRect:
    begin
      //Region := CreateRectRgn(0,0,wWidth,wHeight);
    end;
    stRoundRect :
    begin
      if ARoundingType = rtRounded then
      begin
 
        if ARoundX = -1 then
        begin
         if wMiddleWidth > wMiddleHeight then
            bRoundX := wMiddleHeight
         else bRoundX := wMiddleWidth;
        end;
        if ARoundY = -1 then
        begin
         if wMiddleWidth > wMiddleHeight then
            bRoundY := wMiddleHeight
         else bRoundY := wMiddleWidth;
        end;
        if (bRoundX > wMiddleWidth) then bRoundX := wMiddleWidth;
        if (bRoundY > wMiddleHeight) then bRoundY := wMiddleHeight;
 
        Region := CreateRoundRectRgn(0,0,wWidth,wHeight,bRoundX,bRoundY);
      end
      else if ARoundingType = rtSquared then
      begin
        if ARoundX = -1 then bRoundX := wWidth div 4;
        if ARoundY = -1 then bRoundY := wHeight div 4;
        if (bRoundX > wMiddleWidth) then bRoundX := wMiddleWidth;
        if (bRoundY > wMiddleHeight) then bRoundY := wMiddleHeight;
 
        x1 := bRoundX;
        x2 := wwidth - bRoundX;
        y1 := bRoundY;
        y2 := wHeight-bRoundY;
        if (x1 = x2) and (y1 = y2) then
        begin
          nbPoints := 4;
          getMem(PolyArray,nbPoints*SizeOf(TPoint));
 
          PolyArray[0].x:= x1;
          PolyArray[0].y:= 0;
 
          PolyArray[1].x:= wWidth-1;
          PolyArray[1].y:= y1;
 
          PolyArray[2].x:= x1;
          PolyArray[2].y:= wHeight-1;
 
          PolyArray[3].x:= 0;
          PolyArray[3].y:= y1;
 
          APolyCount:=nbPoints;
 
          //PolyRegion := PolyArray;
          //PolyRegion[1].x:= wWidth;
          //PolyRegion[2].y:= wHeight;
 
        end
        else if (x1=x2) and (y1<>y2) then
        begin
          nbPoints := 6;
          getMem(PolyArray,nbPoints*SizeOf(TPoint));
 
          PolyArray[0].x:= x1;
          PolyArray[0].y:= 0;
 
          PolyArray[1].x:= wWidth-1;
          PolyArray[1].y:= y1;
 
          PolyArray[2].x:= wWidth-1;
          PolyArray[2].y:= y2;
 
          PolyArray[3].x:= x1;
          PolyArray[3].y:= wHeight-1;
 
          PolyArray[4].x:= 0;
          PolyArray[4].y:= y2;
 
          PolyArray[5].x:= 0;
          PolyArray[5].y:= y1;
          APolyCount:=nbPoints;
        end
        else if (x1<>x2) and (y1=y2) then
        begin
          nbPoints := 6;
          getMem(PolyArray,nbPoints*SizeOf(TPoint));
 
          PolyArray[0].x:= x1;
          PolyArray[0].y:= 0;
 
          PolyArray[1].x:= x2;
          PolyArray[1].y:= 0;
 
          PolyArray[2].x:= wWidth-1;
          PolyArray[2].y:= y1;
 
          PolyArray[3].x:= x2;
          PolyArray[3].y:= wHeight-1;
 
          PolyArray[4].x:= x1;
          PolyArray[4].y:= wHeight-1;
 
          PolyArray[5].x:= 0;
          PolyArray[5].y:= y1;
          APolyCount:=nbPoints;
        end
        else
        begin
          nbPoints := 8;
          getMem(PolyArray,nbPoints*SizeOf(TPoint));
 
          PolyArray[0].x:= x1;
          PolyArray[0].y:= 0;
 
          PolyArray[1].x:= x2;
          PolyArray[1].y:= 0;
 
          PolyArray[2].x:= wWidth-1;
          PolyArray[2].y:= y1;
 
          PolyArray[3].x:= wWidth-1;
          PolyArray[3].y:= y2;
 
          PolyArray[4].x:= x2;
          PolyArray[4].y:= wHeight-1;
 
          PolyArray[5].x:= x1;
          PolyArray[5].y:= wHeight-1;
 
          PolyArray[6].x:= 0;
          PolyArray[6].y:= y2;
 
          PolyArray[7].x:= 0;
          PolyArray[7].y:= y1;
          APolyCount:=nbPoints;
        end;
        Region := CreatePolygonRgn(PolyArray,nbPoints,WINDING);
        //FreeMem(PolyArray);
      end;
    end;
    stEllipse :
    begin
      Region := CreateEllipticRgn(0,0,wWidth,wHeight);
    end;
  end;
 
  if AShape = stRect then
  begin
    if AIsGradient then
    begin
      DoDrawGradient(ABmp,ARect,AColor1,AColor2,AGradientType,0);
    end
    else
    begin
      ABmp.Canvas.Brush.Style := bsSolid;
      ABmp.Canvas.Brush.Color := AColor1;
      ABmp.Canvas.FillRect(ARect);
    end;
  end
  else
  begin
    if AIsGradient then
    begin
      DoDrawGradient(ABmp,ARect,AColor1,AColor2,AGradientType,region);
    end
    else
    begin
      DoDrawGradient(ABmp,ARect,AColor1,AColor1,AGradientType,region);
    end;
  end;
end;
 
{**-----------------------------------------------------------------------------
 * @Name        : DoDrawBorders
 * @Description : Dessine des bordures
 -----------------------------------------------------------------------------**}
procedure DoDrawBorders(ABmp:TBitmap;ARect:TRect;AShape:TBZShapeType;ARoundingType : TBZRoundingType; ARoundX, ARoundY: Integer; ABorders : TBZBorders;ABorderWidth:Integer; ABordersColor : TBZBordersColor;ABorderStyle:TPenStyle;APolyArray:PPoint;APolyCount:Byte);
var
  bdrTop, bdrLeft, bdrBottom, bdrRight : Boolean;
  bdrTopColor, bdrLeftColor : TColor;
  bdrBottomColor, bdrRightColor : TColor;
  Delta: Integer;
  i,wWidth, wHeight : Integer;
begin
 
  wWidth  := ARect.Right - ARect.Left -1;
  wHeight := ARect.Bottom - ARect.Top -1;
 
  bdrTop         := bbTop in ABorders;
  bdrLeft        := bbLeft in ABorders;
  bdrBottom      := bbBottom in ABorders;
  bdrRight       := bbRight in ABorders;
 
  bdrTopColor    := ABordersColor[0];
  bdrLeftColor   := ABordersColor[1];
  bdrBottomColor := ABordersColor[2];
  bdrRightColor  := ABordersColor[3];
 
  ABmp.Canvas.Pen.Width := 1;//ABorderWidth; En mettant definissant la largeur c'est la croix et la banniere pour dessiner les bordures correctement
  ABmp.Canvas.Pen.Style := ABorderStyle;
  Delta := ABorderWidth-1;
 
  // Top
  if bdrTop then
  begin
    ABmp.Canvas.Pen.Color := bdrTopColor;
    case AShape of
      stRect :
      begin
        For i:=0 to delta do
        begin
          ABmp.Canvas.MoveTo(ARect.Left,ARect.Top+i);
          ABmp.Canvas.LineTo(ARect.Right,ARect.Top+i);
        end;
      end;
      stRoundRect :
      begin
        if ARoundingType = rtRounded then
        begin
          For i:=0 to delta do
          begin
            ABmp.Canvas.MoveTo(Arect.Left+(ARoundX div 2),ARect.Top+i);
            ABmp.Canvas.LineTo(ARect.Right-(ARoundX div 2)+1,ARect.Top+i);
          end;
        end
        else
        begin
          Case APolyCount of
            4 :
            begin
              ABmp.Canvas.Pen.Width := ABorderWidth;
              ABmp.Canvas.MoveTo(APolyArray[0].x-(ABorderWidth div 2)+1,APolyArray[0].y+ARect.Top);
              ABmp.Canvas.LineTo(APolyArray[1].x-ARect.Left-(ABorderWidth div 2)+1,APolyArray[1].y);
              ABmp.Canvas.Pen.Width := 1;
            end;
            6 :
            begin
              //Horizontal width>Height
              ABmp.Canvas.Pen.Width := ABorderWidth;
              ABmp.Canvas.MoveTo(APolyArray[0].x+ARect.Left-(ABorderWidth div 2),APolyArray[0].y+ARect.Top);
              ABmp.Canvas.LineTo(APolyArray[1].x-ARect.Left-(ABorderWidth div 2),APolyArray[1].y+ARect.Top);
              ABmp.Canvas.MoveTo(APolyArray[0].x+ARect.Left+(ABorderWidth div 2),APolyArray[0].y+ARect.Top);
              ABmp.Canvas.LineTo(APolyArray[5].x+ARect.Left+(ABorderWidth div 2),APolyArray[5].y);
              ABmp.Canvas.Pen.Width := 1;
            end;
            8 :
            begin
              For i:=0 to delta do
              begin
                ABmp.Canvas.MoveTo(APolyArray[0].x+ARect.Left,APolyArray[0].y+ARect.Top+i);
                ABmp.Canvas.LineTo(APolyArray[1].x-ARect.Left,APolyArray[1].y+ARect.Top+i);
              end;
            end;
          end;
        end;
      end;
      stEllipse :
      begin
         ABmp.Canvas.Pen.Width := ABorderWidth;
         ABmp.Canvas.MoveTo(ARect.Left,ARect.Top);
         ABmp.Canvas.Arc(ARect.Left+(ABorderWidth div 2),
                     ARect.Top+(ABorderWidth div 2),
                     ARect.Right-1,
                     ARect.Bottom-1,
                     ARect.Right-(ABorderWidth div 2),wHeight div 2,
                     ARect.Left+(ABorderWidth div 2),wHeight div 2);
 
         ABmp.Canvas.Pen.Width := 1;
      end;
    end;
  end;
  // Left
  if bdrLeft then
  begin
    ABmp.Canvas.Pen.Color := bdrLeftColor;
    case AShape of
      stRect :
      begin
        For i:=0 to delta do
        begin
          ABmp.Canvas.MoveTo(ARect.Left+i,ARect.Top);
          ABmp.Canvas.LineTo(ARect.Left+i,ARect.Bottom);
        end;
      end;
      stRoundRect :
      begin
        if ARoundingType = rtRounded then
        begin
          ABmp.Canvas.Pen.Width := ABorderWidth;
          ABmp.Canvas.Arc(Arect.Left+(ABorderWidth div 2)+ARoundX,
                      ARect.Top+(ABorderWidth div 2)+ARoundY,
                      ARect.Left+(ABorderWidth div 2)-1,
                      ARect.Top+(ABorderWidth div 2)-1,
                      Arect.Left+(ARoundX div 2),ARect.Top,
                      ARect.Left,ARect.Top+(ARoundY div 2));
 
          ABmp.Canvas.Pen.Width := 1;
          For i:=0 to delta do
          begin
            //ABmp.Canvas.Arc(Arect.Left+i+ARoundX,ARect.Top+i+ARoundY,ARect.Left+i,ARect.Top+i,(ARoundX div 2),ARect.Left+i,ARect.Top+i,(ARoundY div 2)); //LeftTop
            ABmp.Canvas.MoveTo(ARect.Left+i,ARect.Top+(ARoundY div 2));
            ABmp.Canvas.LineTo(ARect.Left+i,ARect.Bottom-(ARoundY div 2));
          end;
          ABmp.Canvas.Pen.Width := ABorderWidth;
 
          ABmp.Canvas.Arc(ARect.Left+(ABorderWidth div 2)-1,
                      ARect.Bottom-(ABorderWidth div 2)+1,
                      ARect.Left+(ABorderWidth div 2)+ARoundX,
                      ARect.Bottom-(ABorderWidth div 2)-ARoundY,
                      ARect.left,ARect.Bottom-(ARoundY div 2),
                      (ARoundX div 2),ARect.Bottom);
          ABmp.Canvas.Pen.Width := 1;
 
        end
        else
        begin
          Case APolyCount of
            4 :
            begin
               ABmp.Canvas.Pen.Width := ABorderWidth;
               ABmp.Canvas.MoveTo(APolyArray[0].x+(ABorderWidth div 2)-1,APolyArray[0].y+ARect.Top);
               ABmp.Canvas.LineTo(APolyArray[3].x+ARect.Left+(ABorderWidth div 2)-1,APolyArray[3].y);
               ABmp.Canvas.Pen.Width := 1;
            end;
            6 :
            begin
              for i:=0 to delta do
              begin
                ABmp.Canvas.MoveTo(APolyArray[5].x+i+ARect.Left,APolyArray[5].y);
                ABmp.Canvas.LineTo(APolyArray[4].x+i+ARect.Left,APolyArray[4].y-ARect.Top);
              end;
            end;
            8 :
            begin
 
               ABmp.Canvas.Pen.Width := ABorderWidth;
               ABmp.Canvas.MoveTo(APolyArray[0].x+ARect.Left+(ABorderWidth div 2),APolyArray[0].y+ARect.Top);
               ABmp.Canvas.LineTo(APolyArray[7].x+ARect.Left+(ABorderWidth div 2),APolyArray[7].y+ARect.Top);
               ABmp.Canvas.Pen.Width := 1;
 
               for i:=0 to delta do
               begin
                 ABmp.Canvas.MoveTo(APolyArray[7].x+ARect.Left+i,APolyArray[7].y-1+ARect.Top);
                 ABmp.Canvas.LineTo(APolyArray[6].x+ARect.Left+i,APolyArray[6].y+1-ARect.Top);
               end;
 
               ABmp.Canvas.Pen.Width := ABorderWidth;
               ABmp.Canvas.MoveTo(APolyArray[6].x+ARect.Left+(ABorderWidth div 2),APolyArray[6].y-ARect.Top);
               ABmp.Canvas.LineTo(APolyArray[5].x+ARect.Left+(ABorderWidth div 2),APolyArray[5].y-ARect.Top);
               ABmp.Canvas.Pen.Width := 1;
            end;
          end;
        end;
      end;
      stEllipse :
      begin
           // Nothing todo
      end;
    end;
  end;
  // Bottom
  if bdrBottom then
  begin
    ABmp.Canvas.Pen.Color := bdrBottomColor;
    case AShape of
      stRect :
      begin
        For i:=0 to delta do
        begin
          ABmp.Canvas.MoveTo(ARect.Left,ARect.Bottom-i);
          ABmp.Canvas.LineTo(ARect.Right,ARect.Bottom-i);
        end;
      end;
      stRoundRect :
      begin
        if ARoundingType = rtRounded then
        begin
          For i:=0 to delta do
          begin
            ABmp.Canvas.MoveTo(ARect.Left+(ARoundX div 2),ARect.Bottom-i);
            ABmp.Canvas.LineTo(ARect.Right-(ARoundX div 2),ARect.Bottom-i);
          end;
        end
        else
        begin
          Case APolyCount of
            4 :
            begin
              ABmp.Canvas.Pen.Width := ABorderWidth;
              ABmp.Canvas.MoveTo(APolyArray[2].x-(ABorderWidth div 2),APolyArray[2].y-ARect.Top);
              ABmp.Canvas.LineTo(APolyArray[3].x+ARect.Left-(ABorderWidth div 2),APolyArray[3].y);
              ABmp.Canvas.Pen.Width := 1;
            end;
            6 :
            begin
              ABmp.Canvas.Pen.Width := ABorderWidth;
              ABmp.Canvas.MoveTo(APolyArray[2].x-ARect.Left-(ABorderWidth div 2),APolyArray[2].y);
              ABmp.Canvas.LineTo(APolyArray[3].x-ARect.Left-(ABorderWidth div 2),APolyArray[3].y-ARect.Top);
 
              ABmp.Canvas.MoveTo(APolyArray[3].x-ARect.Left+(ABorderWidth div 2),APolyArray[3].y-ARect.Top);
              ABmp.Canvas.LineTo(APolyArray[4].x+ARect.Left+(ABorderWidth div 2),APolyArray[4].y-ARect.Top);
              ABmp.Canvas.Pen.Width := 1;
            end;
            8 :
            begin
              For i:=0 to delta do
              begin
                ABmp.Canvas.MoveTo(APolyArray[4].x-ARect.Left,APolyArray[4].y-i-ARect.Top);
                ABmp.Canvas.LineTo(APolyArray[5].x+ARect.Left,APolyArray[5].y-i-ARect.Top);
              end;
            end;
          end;
        end;
      end;
      stEllipse :
      begin
         ABmp.Canvas.Pen.Width := ABorderWidth;
         ABmp.Canvas.MoveTo(Arect.Left,ARect.Top);
         ABmp.Canvas.Arc(ARect.Right-1,
                     ARect.Bottom-1,
                     ARect.Left+(ABorderWidth div 2),
                     ARect.Top+1,
                     ARect.Left+(ABorderWidth div 2),wHeight div 2,
                     ARect.Right-(ABorderWidth div 2),wHeight div 2);
         ABmp.Canvas.Pen.Width := 1;
      end;
    end;
 
  end;
  // Right
  if bdrRight then
  begin
    ABmp.Canvas.Pen.Color := bdrRightColor;
    case AShape of
      stRect :
      begin
        For i:=0 to delta do
        begin
          ABmp.Canvas.MoveTo(ARect.Right-i , ARect.Top);
          ABmp.Canvas.LineTo(ARect.Right-i , ARect.Bottom);
        end;
      end;
      stRoundRect :
      begin
        if ARoundingType = rtRounded then
        begin
          ABmp.Canvas.Pen.Width := ABorderWidth;
 
 
          ABmp.Canvas.Arc(ARect.Right-(ABorderWidth div 2)+1,
                      ARect.Top+(ABorderWidth div 2)-1,
                      ARect.Right-(ABorderWidth div 2)-ARoundX,
                      ARect.Top+(ABorderWidth div 2)+ARoundY,
                      ARect.Right,ARect.Top+ (ARoundY div 2),
                      ARect.Right-(ARoundX div 2),ARect.Top+(ABorderWidth div 2));   //RightTop
 
          ABmp.Canvas.Pen.Width := 1;
          For i:=0 to delta do
          begin
            ABmp.Canvas.MoveTo(ARect.Right-i,ARect.Top+1+(ARoundY div 2));
            ABmp.Canvas.LineTo(ARect.Right-i,ARect.Bottom-1-(ARoundY div 2));
          end;
          ABmp.Canvas.Pen.Width := ABorderWidth;
          ABmp.Canvas.Arc(ARect.Right-(ABorderWidth div 2)+1,
                      ARect.Bottom-(ABorderWidth div 2)+1,
                      ARect.Right-(ABorderWidth div 2)-ARoundX,
                      ARect.Bottom-(ABorderWidth div 2)-ARoundY,
                      ARect.Right-(ARoundX div 2),ARect.Bottom-(ABorderWidth div 2),
                      ARect.Right-(ABorderWidth div 2),ARect.Bottom-(ARoundY div 2));
 
          ABmp.Canvas.Pen.Width := 1;
        end
        else
        begin
          Case APolyCount of
            4 :
            begin
              ABmp.Canvas.Pen.Width := ABorderWidth;
              ABmp.Canvas.MoveTo(APolyArray[1].x-Arect.Left-(ABorderWidth div 2),APolyArray[1].y);
              ABmp.Canvas.LineTo(APolyArray[2].x-(ABorderWidth div 2)-1,APolyArray[2].y+1-ARect.Top);
              ABmp.Canvas.Pen.Width := 1;
            end;
            6 :
            begin
              For i:=0 to delta do
              begin
                ABmp.Canvas.MoveTo(APolyArray[1].x-i-ARect.Left,APolyArray[1].y+ARect.Top);
                ABmp.Canvas.LineTo(APolyArray[2].x-i-ARect.Left,APolyArray[2].y);
              end;
            end;
            8 :
            begin
                ABmp.Canvas.Pen.Width := ABorderWidth;
                ABmp.Canvas.MoveTo(APolyArray[1].x-ARect.Left-(ABorderWidth div 2),APolyArray[1].y+ARect.Top);
                ABmp.Canvas.LineTo(APolyArray[2].x-ARect.Left-(ABorderWidth div 2),APolyArray[2].y+ARect.Top);
                ABmp.Canvas.Pen.Width := 1;
 
                For i:=0 to delta do
                begin
                  ABmp.Canvas.MoveTo(APolyArray[2].x-i-ARect.Left,APolyArray[2].y-1+ARect.Top);
                  ABmp.Canvas.LineTo(APolyArray[3].x-i-ARect.Left,APolyArray[3].y+1-ARect.Top);
                end;
 
                ABmp.Canvas.Pen.Width := ABorderWidth;
                ABmp.Canvas.MoveTo(APolyArray[3].x-ARect.Left-(ABorderWidth div 2),APolyArray[3].y-ARect.Top);
                ABmp.Canvas.LineTo(APolyArray[4].x-ARect.Left-(ABorderWidth div 2),APolyArray[4].y-ARect.Top);
                ABmp.Canvas.Pen.Width := 1;
            end;
          end;
        end;
      end;
      stEllipse :
      begin
       // Nothing Todo
      end;
    end;
  end;
end;
 
{**-----------------------------------------------------------------------------
 * @Name        : DoDrawText
 * @Description : Dessine un texte
 -----------------------------------------------------------------------------**}
procedure DoDrawText(ABmp:TBitmap;ARect:TRect; AText:String; AStyle : TBZTextStyle; AHorizontalLayout:TBZHorizontalLayout; AVerticalLayout:TBZVerticalLayout;AWordWrap, AEndEllipsis, ASingleLine, AShowPrefix, AClipping:Boolean);
var
  wAlignment : TAlignment;
  wVerticalLayout : TTextLayout;
  wColor     : TColor;
  wRect      : TRect;
  ATextStyle : TTextStyle;
begin
 
 Case AHorizontalLayout of
   hlLeft   : wAlignment := taLeftJustify;
   hlRight  : wAlignment := taRightJustify;
   hlCenter : wAlignment := taCenter;
 end;
 
 Case AVerticalLayout of
   vlTop    : wVerticalLayout := tlTop;
   vlBottom : wVerticalLayout := tlBottom;
   vlCenter : wVerticalLayout := tlCenter;
 end;
 
 
 ABmp.Canvas.Brush.Style:= bsClear;
 ATextStyle.Opaque    := True;
 
 ATextStyle.Alignment  := wAlignment;
 ATextStyle.ShowPrefix := AShowPrefix;
 ATextStyle.Wordbreak  := AWordWrap;
 ATextStyle.Layout     := wVerticalLayout;
 ATextStyle.Clipping   := AClipping;
 ATextStyle.SystemFont := False;
 
 ATextStyle.RightToLeft:= False;
 ATextStyle.ExpandTabs := False;
 
 
 if AWordWrap then
 begin
   ATextStyle.SingleLine  := False;
   ATextStyle.EndEllipsis := False;
 end
 else
 begin
   ATextStyle.SingleLine  := ASingleLine;
   ATextStyle.EndEllipsis := AEndEllipsis;
 end;
 ABmp.Canvas.TextStyle := ATextStyle;
 wColor := ABmp.Canvas.Font.Color;
 
 Case AStyle of
   tsDefault :
   begin
     if (wAlignment = taLeftJustify) then ABmp.Canvas.TextRect(ARect,ARect.Left,0,AText,ATextStyle) // Correction Bug d'affichage
     else ABmp.Canvas.TextRect(ARect,0,0,AText,ATextStyle);
   end;
   tsBevel :
   begin
     ABmp.Canvas.Font.Color:=DarkenColor(wColor,80);
     wRect.Top    := ARect.Top + 1;
     wRect.left   := ARect.Left + 1;
     wRect.Bottom := ARect.Bottom + 1;
     wRect.Right  := ARect.Right + 1;
     ABmp.Canvas.TextRect(wRect,0,0,AText,ATextStyle);
 
     ABmp.Canvas.Font.Color:=LightenColor(wColor,80);
     wRect.Top    := ARect.Top - 1;
     wRect.left   := ARect.Left - 1;
     wRect.Bottom := ARect.Bottom - 1;
     wRect.Right  := ARect.Right - 1;
     ABmp.Canvas.TextRect(wRect,0,0,AText,ATextStyle);
 
     ABmp.Canvas.Font.Color:=wColor;
     ABmp.Canvas.TextRect(ARect,0,0,AText,ATextStyle);
   end;
   tsEmbossed :
   begin
     ABmp.Canvas.Font.Color:=LightenColor(wColor,80);
     wRect.Top    := ARect.Top + 1;
     wRect.left   := ARect.Left + 1;
     wRect.Bottom := ARect.Bottom + 1;
     wRect.Right  := ARect.Right + 1;
     ABmp.Canvas.TextRect(wRect,0,0,AText,ATextStyle);
 
     ABmp.Canvas.Font.Color:=wColor;
     ABmp.Canvas.TextRect(ARect,0,0,AText,ATextStyle);
   end;
   tsRaised :
   begin
     ABmp.Canvas.Font.Color:=LightenColor(wColor,80);
     wRect.Top    := ARect.Top + 1;
     wRect.left   := ARect.Left + 1;
     wRect.Bottom := ARect.Bottom + 1;
     wRect.Right  := ARect.Right + 1;
     ABmp.Canvas.TextRect(wRect,0,0,AText,ATextStyle);
 
     ABmp.Canvas.Font.Color:=DarkenColor(wColor,80);
     wRect.Top    := ARect.Top - 1;
     wRect.left   := ARect.Left - 1;
     wRect.Bottom := ARect.Bottom - 1;
     wRect.Right  := ARect.Right - 1;
     ABmp.Canvas.TextRect(wRect,0,0,AText,ATextStyle);
 
     ABmp.Canvas.Font.Color:=wColor;
     ABmp.Canvas.TextRect(ARect,0,0,AText,ATextStyle);
   end;
   tsContour :
   begin
     wRect.Top    := ARect.Top-1;
     wRect.left   := ARect.Left;
     wRect.Bottom := ARect.Bottom- 1;
     wRect.Right  := ARect.Right;
     ABmp.Canvas.TextRect(wRect,0,0,AText,ATextStyle);
 
     wRect.Top    := ARect.Top+1;
     wRect.left   := ARect.Left;
     wRect.Bottom := ARect.Bottom+1;
     wRect.Right  := ARect.Right;
     ABmp.Canvas.TextRect(wRect,0,0,AText,ATextStyle);
 
     wRect.Top    := ARect.Top;
     wRect.left   := ARect.Left-1;
     wRect.Bottom := ARect.Bottom;
     wRect.Right  := ARect.Right-1;
     ABmp.Canvas.TextRect(wRect,0,0,AText,ATextStyle);
 
     wRect.Top    := ARect.Top;
     wRect.left   := ARect.Left+1;
     wRect.Bottom := ARect.Bottom;
     wRect.Right  := ARect.Right+1;
     ABmp.Canvas.TextRect(wRect,0,0,AText,ATextStyle);
 
     ABmp.Canvas.Font.Color:=clInfoBK; //Transparent
     ABmp.Canvas.TextRect(ARect,0,0,AText,ATextStyle);
     ABmp.Canvas.Font.Color:=wColor;
   end;
 end;
end;
 
procedure DoDrawCanvasText(ACanvas:TCanvas;ARect:TRect; AText:String; AStyle : TBZTextStyle; AHorizontalLayout:TBZHorizontalLayout; AVerticalLayout:TBZVerticalLayout;AWordWrap, AEndEllipsis, ASingleLine, AShowPrefix, AClipping:Boolean);
var
  wAlignment : TAlignment;
  wVerticalLayout : TTextLayout;
  wColor     : TColor;
  wRect      : TRect;
  ATextStyle : TTextStyle;
begin
 
 Case AHorizontalLayout of
   hlLeft   : wAlignment := taLeftJustify;
   hlRight  : wAlignment := taRightJustify;
   hlCenter : wAlignment := taCenter;
 end;
 
 Case AVerticalLayout of
   vlTop    : wVerticalLayout := tlTop;
   vlBottom : wVerticalLayout := tlBottom;
   vlCenter : wVerticalLayout := tlCenter;
 end;
 
 
 ACanvas.Brush.Style:= bsClear;
 ATextStyle.Opaque    := False;
 
 ATextStyle.Alignment  := wAlignment;
 ATextStyle.ShowPrefix := AShowPrefix;
 ATextStyle.Wordbreak  := AWordWrap;
 ATextStyle.Layout     := wVerticalLayout;
 ATextStyle.Clipping   := AClipping;
 ATextStyle.SystemFont := False;
 
 ATextStyle.RightToLeft:= False;
 ATextStyle.ExpandTabs := False;
 
 
 if AWordWrap then
 begin
   ATextStyle.SingleLine  := False;
   ATextStyle.EndEllipsis := False;
 end
 else
 begin
   ATextStyle.SingleLine  := ASingleLine;
   ATextStyle.EndEllipsis := AEndEllipsis;
 end;
 ACanvas.TextStyle := ATextStyle;
 wColor := ACanvas.Font.Color;
 
 Case AStyle of
   tsDefault :
   begin
     if (wAlignment = taLeftJustify) then ACanvas.TextRect(ARect,ARect.Left,0,AText) // Correction Bug d'affichage
     else ACanvas.TextRect(ARect,0,0,AText);
   end;
   tsBevel :
   begin
     ACanvas.Font.Color:=DarkenColor(wColor,80);
     wRect.Top    := ARect.Top + 1;
     wRect.left   := ARect.Left + 1;
     wRect.Bottom := ARect.Bottom + 1;
     wRect.Right  := ARect.Right + 1;
     ACanvas.TextRect(wRect,0,0,AText);
 
     ACanvas.Font.Color:=LightenColor(wColor,80);
     wRect.Top    := ARect.Top - 1;
     wRect.left   := ARect.Left - 1;
     wRect.Bottom := ARect.Bottom - 1;
     wRect.Right  := ARect.Right - 1;
     ACanvas.TextRect(wRect,0,0,AText);
 
     ACanvas.Font.Color:=wColor;
     ACanvas.TextRect(ARect,0,0,AText);
   end;
   tsEmbossed :
   begin
     ACanvas.Font.Color:=LightenColor(wColor,80);
     wRect.Top    := ARect.Top + 1;
     wRect.left   := ARect.Left + 1;
     wRect.Bottom := ARect.Bottom + 1;
     wRect.Right  := ARect.Right + 1;
     ACanvas.TextRect(wRect,0,0,AText);
 
     ACanvas.Font.Color:=wColor;
     ACanvas.TextRect(ARect,0,0,AText);
   end;
   tsRaised :
   begin
     ACanvas.Font.Color:=LightenColor(wColor,80);
     wRect.Top    := ARect.Top + 1;
     wRect.left   := ARect.Left + 1;
     wRect.Bottom := ARect.Bottom + 1;
     wRect.Right  := ARect.Right + 1;
     ACanvas.TextRect(wRect,0,0,AText);
 
     ACanvas.Font.Color:=DarkenColor(wColor,80);
     wRect.Top    := ARect.Top - 1;
     wRect.left   := ARect.Left - 1;
     wRect.Bottom := ARect.Bottom - 1;
     wRect.Right  := ARect.Right - 1;
     ACanvas.TextRect(wRect,0,0,AText);
 
     ACanvas.Font.Color:=wColor;
     ACanvas.TextRect(ARect,0,0,AText);
   end;
   tsContour :
   begin
     wRect.Top    := ARect.Top-1;
     wRect.left   := ARect.Left;
     wRect.Bottom := ARect.Bottom- 1;
     wRect.Right  := ARect.Right;
     ACanvas.TextRect(wRect,0,0,AText);
 
     wRect.Top    := ARect.Top+1;
     wRect.left   := ARect.Left;
     wRect.Bottom := ARect.Bottom+1;
     wRect.Right  := ARect.Right;
     ACanvas.TextRect(wRect,0,0,AText);
 
     wRect.Top    := ARect.Top;
     wRect.left   := ARect.Left-1;
     wRect.Bottom := ARect.Bottom;
     wRect.Right  := ARect.Right-1;
     ACanvas.TextRect(wRect,0,0,AText);
 
     wRect.Top    := ARect.Top;
     wRect.left   := ARect.Left+1;
     wRect.Bottom := ARect.Bottom;
     wRect.Right  := ARect.Right+1;
     ACanvas.TextRect(wRect,0,0,AText);
 
     ACanvas.Font.Color:=clInfoBK; //Transparent
     ACanvas.TextRect(ARect,0,0,AText);
     ACanvas.Font.Color:=wColor;
   end;
 end;
end;
{**-----------------------------------------------------------------------------
 * @Name        : DoDrawGlyph
 * @Description : Dessine une image avec redimensionnement au besoin
 -----------------------------------------------------------------------------**}
procedure DoDrawGlyph(ABmp:TBitmap; AGlyph:TPicture;ARect:TRect;AHorizontalLayout:TBZHorizontalLayout;AVerticalLayout:TBZVerticalLayout;AAdjustH, AAdjustV:Integer;ATransp:Boolean);
var
  wWidth,
  wHeight    : Integer;
  newWidth,NewHeight,x,y,w,h    : Integer;
  NeedResize : Boolean;
  wRect,zRect      : TRect;
begin
 
  if assigned(AGlyph.Graphic) then
  begin
    NeedResize := false;
 
    wWidth  := (ARect.Right - ARect.Left);
    wHeight := (ARect.Bottom - ARect.Top);
 
    w := AGlyph.Width;
    h := AGlyph.Height;
 
    // Redimensionnement de l'image si plus grande que le rectangle de destination
    if (w>wWidth) or (h>wHeight) then
    begin
      NeedResize := True;
    end;
 
    AGlyph.Bitmap.Transparent := ATransp;
 
    Case AHorizontalLayout of
      hlLeft   : x := ARect.Left;
      hlCenter : x := ARect.Left + ((wWidth div 2) - (w div 2));
      hlRight  : x := ARect.Right - w;
    end;
 
    Case AVerticalLayout of
      vlTop    : y := ARect.Top;
      vlCenter : y := ARect.Top + ((wHeight div 2) - (h div 2));
      vlBottom : y := ARect.Bottom - h;
    end;
 
    if NeedResize then
    begin
      if w<>h then
      begin
       if h > w then
       begin
        newHeight := wHeight;
        newWidth := (newheight * w) div h;
       end
       else
       begin
          newWidth := wWidth;
          newHeight := (newwidth * h) div w;
       end;
     end
     else
     begin
        newHeight := h;
        newWidth := w;
     end;
     wRect.Left   := x + AAdjustH;
     wRect.Top    := y + AAdjustV;
     wRect.Right  := wRect.Left+newWidth;
     wRect.Bottom := wRect.Top+newHeight;
     ABmp.Canvas.StretchDraw(wRect,AGlyph.Graphic);
    end
    else
    begin
     wRect.Left   := x + AAdjustH;
     wRect.Top    := y + AAdjustV;
     wRect.Right  := wRect.Left+AGlyph.Width;
     wRect.Bottom := wRect.Top+AGlyph.Height;
 
     zRect.Left := 0;
     zRect.Top := 0;
     zRect.Right := AGlyph.Width;
     zRect.Bottom := AGlyph.Height;
     // Du à la transparence je pense, on doit ici utiliser BrushCopy sinon
     // Avec Draw,StretchDraw et CopyRect le Bitmap (ABmp) est effacé
     Abmp.Canvas.BrushCopy(wRect,AGlyph.Bitmap,zRect,clFuchsia);
    end;
  end;
end;
 
{**-----------------------------------------------------------------------------
 * @Name        : DoDrawArrow
 * @Description : Dessine une flêche
 -----------------------------------------------------------------------------**}
procedure DoDrawArrow(ABmp:TBitmap; ARect: TRect; ADirection: TBZDirection; AColor, ABorderColor: TColor;AABorderWidth:Integer;AAdjustH, AAdjustV:Integer);
 var
   Points : array[0..3] of TPoint;
   cx,cy: Integer;
   wRect : TRect;
 begin
  wRect.Left   := ARect.Left + AAdjustH;
  wRect.Right  := ARect.Right + AAdjustH;
  wRect.Top    := ARect.Top + AAdjustV;
  wRect.Bottom := ARect.Bottom + AAdjustV;
  cx := wRect.Right  - wRect.Left ;
  cy := wRect.Bottom  - wRect.Top;
 
  case ADirection of
    dToTop:
    begin
      Points[0] := Point(wRect.Left , wRect.Bottom);
      Points[1] := Point(wRect.Right, wRect.Bottom);
      Points[2] := Point(wRect.Left+(cx div 2), wRect.Top);
    end;
    dToBottom:
    begin
      Points[0] := Point(wRect.Left, wRect.Top);
      Points[1] := Point(wRect.Right, wRect.Top);
      Points[2] := Point(wRect.Left+(cx div 2), wRect.Bottom);
    end;
    dToLeft:
    begin
      Points[0] := Point(wRect.Right, wRect.Top);
      Points[1] := Point(wRect.Right, wRect.Bottom);
      Points[2] := Point(wRect.Left, wRect.Top+(cy div 2));
    end;
    dToRight:
    begin
      Points[0] := Point(wRect.Left, wRect.Top);
      Points[1] := Point(wRect.Left, wRect.Bottom);
      Points[2] := Point(wRect.Right,wRect.Top+(cy div 2));
    end;
  end;
  Points[3] := Points[0];  // Obligatoire sous Lazarus/FPC sinon le polygone n'est pas correctement dessiné
 
  ABmp.Canvas.Brush.Style:=bsSolid;
  ABmp.Canvas.Brush.Color:=AColor;
  ABmp.Canvas.Pen.Width:=AABorderWidth;
 
  ABmp.Canvas.Pen.Color:=ABorderColor;
 
  ABmp.Canvas.Polygon(Points);
end;
 
 
//==============================================================================
//==============================================================================
end.

Bz_Label

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
 
unit bz_Label;
 
{$mode objfpc}{$H+}
 
interface
 
uses
  Classes, SysUtils, Forms, Controls, Graphics, Dialogs, ActnList,
  LCLProc, LCLType, LCLIntf, LResources,LMessages, FPImage,
 
  bz_Styles,
  bz_Graphics;
 
type
  TBZCustomLabel = class(TGraphicControl)
  private
    { Private declarations }
 
    FBackGround, FBuffer : TBitmap;
    {$ifdef FPC}  Fmem : TMemoryStream;    {$endif}
 
    FStyle : TBZCaptionStyle;
    FCaption : TCaption;
 
    FAutoSizing : Boolean;
 
    FNeededUpdate : Boolean;
 
    FAntiAlias      : Boolean;
 
    procedure setCaption(AValue:TCaption);
    procedure AutoAdjustSize;
    procedure setAutoSizing(AValue:Boolean);
 
    procedure CaptureBackground;
    procedure DrawLabel(var ABmp:TBitmap);
    procedure DrawCanvasLabel;
 
   // procedure PaintHandler(var TheMessage: TLMPaint);override;
   // procedure PaintWindow(DC: HDC); override;
  protected
    { Protected declarations }
     // procedure SetParent(AParent: TWinControl); override;
   // procedure WMPaint(var Message: TLMPaint); message LM_PAINT;
    //Procedure CreateParams(var Params : TCreateParams);override;
    //procedure WMEraseBkgnd(var Message: TLMEraseBkgnd); message LM_ERASEBKGND;
 
 
    procedure DoChangeStyle(ASender: TObject; AData: PtrInt);
 
    procedure Loaded;override;
 
    procedure DoPaint;// override;
    procedure Paint; override;
  public
    { Public declarations }
    constructor Create(AOwner: TComponent);override;
    destructor Destroy; override;
    //procedure Invalidate; override;
   // procedure EraseBackground(DC: HDC); override;
   // procedure DefaultHandler(var AMessage); override;
  published
    { Published declarations }
 
    property Style    : TBZCaptionStyle Read FStyle    Write FStyle;
    property Caption  : TCaption        Read FCaption  Write setCaption;
    property AutoSizing : Boolean       Read FAutoSizing Write setAutoSizing;
    property AntiAlias  : Boolean       Read FAntialias  Write FAntialias default false;
  end;
 
Type
  TBZLabel = class(TBZCustomLabel)
  published
    { Published declarations }
    property Caption;
    property Style;
    property Align;
 
    property Anchors;
    property AutoSizing;
    property BidiMode;
 
    property Constraints;
    property DragCursor;
    property DragKind;
    property DragMode;
    property Enabled;
 
    property ParentBidiMode;
    property ParentColor;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
 
    property ShowHint;
 
    property Visible;
 
    property OnChangeBounds;
    property OnClick;
    property OnContextPopup;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnMouseDown;
    property OnMouseEnter;
    property OnMouseLeave;
    property OnMouseMove;
    property OnMouseUp;
    property OnMouseWheel;
    property OnMouseWheelDown;
    property OnMouseWheelUp;
    property OnResize;
    property OnStartDrag;
 
  end;
 
procedure Register;
 
implementation
 
uses FPCanvas;
 
procedure Register;
begin
  {$I ../../ressources/bz_label_icon.lrs}
  RegisterComponents('Beanz Controls',[TBZLabel]);
end;
 
//==============================================================================
//==============================================================================
// 1. TBZCustomLabel
//==============================================================================
 
//==== PRIVATE =================================================================
 
{**------------------------------------------------------------------------------
 * Setters pour les differentes propriétés
------------------------------------------------------------------------------**}
 
 
procedure TBZCustomLabel.setCaption(AValue:TCaption);
begin
  if FCaption = AValue then exit;
  FCaption := AValue;
  FStyle.SetText(AValue);
  FNeededUpdate:=True;
  Paint;
end;
 
procedure TBZCustomLabel.setAutoSizing(AValue: Boolean);
begin
   if FAutoSizing = AValue then Exit;
   FAutoSizing := AValue;
   if FAutoSizing then AutoAdjustSize;
end;
 
//------------------------------------------------------------------------------
 
procedure TBZCustomLabel.AutoAdjustSize;
Var
  cWidth, cHeight : Integer;
  AFont : TFont;
begin
  if (FCaption<>'') then
  begin
    AFont:=Canvas.Font;
    Canvas.Font:=FStyle.Font;
    cWidth  := Canvas.GetTextWidth(FCaption)+4;
    cHeight := Canvas.GetTextHeight(FCaption)+4;
    Canvas.Font:= AFont;
    if (Width <> cWidth) or (Height <> cHeight) then
    begin
      Width := cWidth;
      if (Height <> cHeight) then Height := cHeight;
      if FStyle.Shadow then
      begin
        Width:=Width+FStyle.ShadowDepth;
        Height:=Height+FStyle.ShadowDepth;
      end;
      FBuffer.SetSize(Width,Height);
      FNeededUpdate := True;
    end;
  end;
end;
 
procedure TBZCustomLabel.DrawLabel(var ABmp:TBitmap);
var
  BackBuffer : TBitmap;
  AntialiasMode : TMitchelInterpolation;
  wRect : TRect;
begin
  BackBuffer := TBitmap.Create;
  BackBuffer.SetSize(Self.Width,Self.Height);
  Backbuffer.PixelFormat := pf32Bit;
  Backbuffer.Transparent:=true;
  BackBuffer.TransparentMode := tmFixed;
  Backbuffer.TransparentColor:=clNone; // On doit utiliser clNone sinon des artefacts se produisent
  AntialiasMode:=TMitchelInterpolation.Create;
  BackBuffer.Canvas.Interpolation :=AntialiasMode;
  Backbuffer.Canvas.AntialiasingMode:=amOn;
 
 
 // if (csDesigning in ComponentState) then
 // begin
    Backbuffer.Canvas.Brush.Style:=bsClear;
  //  Backbuffer.Canvas.Brush.Color := clNone;
  //  Backbuffer.Canvas.FillRect(Rect(0, 0, Width, Height));
 // end
 // else
  BackBuffer.Assign(FBackground);
  //BackBuffer.Canvas.Draw(0,0,FBackground);
 
 
  wRect.Left   := 0;
  wRect.Top    := 0;
  wRect.Right  := Width;
  wRect.Bottom := Height;
 
  FStyle.PaintTo(BackBuffer,wRect);
 
  if FAntiAlias then
  begin
    DoCanvasAntiAlias(BackBuffer.Canvas,wRect);
    DoDrawText(BackBuffer,wRect,FStyle.GetText,FStyle.Style,FStyle.AlignH,FStyle.AlignV,FStyle.WordWrap,FStyle.EndEllipsis,FStyle.SingleLine,FStyle.ShowPrefix,FStyle.Clipping);
  end;
//  ABmp.Canvas.Draw(0,0,BackBuffer);
  ABmp.Assign(BackBuffer);
  AntialiasMode.Free;
  BackBuffer.Free;
 
end;
 
procedure TBZCustomLabel.DrawCanvasLabel;
var
  wRect : TRect;
begin
 
  wRect.Left   := 0;
  wRect.Top    := 0;
  wRect.Right  := Width;
  wRect.Bottom := Height;
 
  FStyle.PaintToCanvas(Canvas,wRect);
 
  if FAntiAlias then DoCanvasAntiAlias(Canvas,wRect);
 
  DoDrawCanvasText(Canvas,wRect,FStyle.GetText,FStyle.Style,FStyle.AlignH,FStyle.AlignV,FStyle.WordWrap,FStyle.EndEllipsis,FStyle.SingleLine,FStyle.ShowPrefix,FStyle.Clipping);
 
end;
 
//==== PROTECTED ===============================================================
//procedure TBZCustomLabel.EraseBackground(DC: HDC);
//begin
//  // DoNothing;
//
//end;
 
//Procedure TBZCustomLabel.CreateParams(var Params : TCreateParams);
//Begin
//  inherited CreateParams(Params);
//  //Params.ExStyle := Params.ExStyle or WS_EX_TRANSPARENT;
//  With Params do
//  begin
//    ExStyle := ExStyle or WS_EX_TRANSPARENT;
//    //ExStyle := ExStyle and not WS_EX_CLIENTEDGE;
//    //ExStyle := ExStyle and not WS_EX_WINDOWEDGE;
//    //ExStyle := ExStyle and not WS_EX_STATICEDGE;
//    //
//    //Style := Style and not WS_CLIPCHILDREN;
//    //Style := Style and not WS_CLIPSIBLINGS;
//    //Style := Style and not WS_BORDER;
//    //Style := Style and not WS_THICKFRAME;
//    //Style := Style and not WS_DLGFRAME;
//    //Style := Style and not WS_CHILD;
//  end;
//End;
 
//procedure TBZCustomLabel.WMEraseBkgnd(var Message: TLMEraseBkgnd);
//
//begin
// // Application.
//  if (csDesigning In ComponentState) then
//    inherited
//  else
//  begin
//      if not Assigned( FBackground ) then
//        Capturebackground;
//
//        if not (csLoading in ComponentState) then
//        begin
//          //canvas.handle := Message.DC;
//          canvas.draw( 0, 0, FBackground );
//          //FBuffer.Canvas.Draw(0,0,FBackground);
//        end;
//    Message.result := 1;
//  end;
//end;
 
procedure TBZCustomLabel.CaptureBackground;
var
  //ScreenDC: HDC;
  TmpBmp : TBitmap;
  SourceRect, DestRect : TRect;
begin
  Visible:=False;
  if not(Assigned(FBackground)) then
    FBackground := TBitmap.Create;
 
  with Fbackground do
  begin
    pixelformat:=pf32bit;
    width := Width;
    height := Height;
  end;
 
 
 
//  SourceRect.TopLeft :=  ClientToScreen(clientrect.TopLeft);
//  SourceRect.BottomRight :=ClientToScreen( clientrect.BottomRight );
    try
      TmpBmp := TBitmap.Create;
      TmpBmp.PixelFormat:=pf32bit;
      //ScreenDC :=GetDC(0); //GetDC(Parent.Handle);
      //TmpBmp.LoadFromDevice(ScreenDC);
      TmpBmp:=TForm(Self.Owner).GetFormImage;
      SourceRect.Left:=Left;
      SourceRect.Top:=Top;
      SourceRect.Right:=Left+Width;
      SourceRect.Bottom:=Top+Height;
 
      DestRect.Left:=0;
      DestRect.Top:=0;
      DestRect.Right:=Width;
      DestRect.Bottom:=Height;
     // ShowMessage('TmpSize : '+inttostr(TmpBmp.Width)+'x'+inttostr(TmpBmp.Height));
     // ShowMessage('Rect : '+inttostr(Left)+'-'+inttostr(Top)+' Size : '+inttostr(Width)+'x'+inttostr(Height));
      Fbackground.Canvas.CopyRect( DestRect, TmpBmp.Canvas, SourceRect );
     // bitblt(FBackground.Handle,0,0,width,height,TmpBmp.Handle,left,top,SrcCopy);
      //BitmapCopy(TmpBmp,FBackground,left,top,0,0,Width,Height);
     // TmpBmp.Canvas.;
      //FBackground.Canvas.BrushCopy( DestRect, TmpBmp, SourceRect,clNone );
    finally
      //TmpBmp.free;
     // ReleaseDC(0,ScreenDC);
    end;
   Visible:=True;
end;
 
 
//procedure TBZCustomLabel.SetParent(AParent: TWinControl);
//begin
//  Inherited SetParent(AParent);
//  {The trick needed to make it all work! I don't know if changing the parent's
//  style is a good idea, but it only removes the WS_CLIPCHILDREN style which
//  shouldn't cause any problems.}
//  if Parent <> Nil then
//    SetWindowLong(
//      Parent.Handle,
//      GWL_STYLE,
//      GetWindowLong(Parent.Handle, GWL_STYLE) And Not WS_ClipChildren
//    );
//end;
 
//procedure TBZCustomLabel.Invalidate;
//var
//  Rect:TRect;
//begin
//  Rect := BoundsRect;
//  if (Parent <> Nil) and Parent.HandleAllocated then
//    InvalidateRect(Parent.Handle, @Rect, True)
//  else
//    Inherited Invalidate;
//end;
 
//procedure TBZCustomLabel.DefaultHandler(var AMessage);
//begin
//  // DoNothing;
//end;
//
//procedure TBZCustomLabel.PaintWindow(DC: HDC);
//begin
//  //Message.Msg := LM_PAINT;
//  //Message.WParam := WParam(DC);
//  //Message.LParam := 0;
//  //Message.Result := 0;
//  //Perform(LM_PAINT, WParam(DC), 0);
//end;
//
//procedure TBZCustomLabel.WMPaint(var Message: TLMPaint);
//begin
//  if Message.DC <> 0 then
//  begin
//    Canvas.Lock;
//    try
//      //debugln('TGraphicControl.WMPaint A ',DbgSName(Self));
//      Canvas.Handle := Message.DC;
//      try
//        DoPaint;
//      finally
//        Canvas.Handle := 0;
//      end;
//    finally
//      Canvas.Unlock;
//    end;
//  end;
//end;
 
procedure TBZCustomLabel.Paint;
begin
  //if not Assigned( FBackground ) then Capturebackground;
  //canvas.draw( 0, 0, FBackground );
  if FNeededUpdate then
  begin
 
    DrawLabel(FBuffer);
  end;
  //DoPaint;
  Canvas.Draw(0,0,FBuffer);
  FNeededUpdate:=False;
end;
{**-----------------------------------------------------------------------------
 * @Name        : DoChangeStyles
 * @Description : Met à jour le style de notre Label
 -----------------------------------------------------------------------------**}
procedure TBZCustomLabel.DoChangeStyle(ASender: TObject; AData: PtrInt);
begin
  FNeededUpdate:=True;
  Paint;
 
  //Invalidate;
end;
 
{**-----------------------------------------------------------------------------
 * @Name        : Loaded
 * @Description : Initialisation au chargement du Label
 -----------------------------------------------------------------------------**}
procedure TBZCustomLabel.Loaded;
begin
  if FAutoSizing then AutoAdjustSize;
  Capturebackground;
  FNeededUpdate := True;
  inherited Loaded;
end;
 
{**-----------------------------------------------------------------------------
 * @Name        : Paint
 * @Description : Affiche notre label
 -----------------------------------------------------------------------------**}
procedure TBZCustomLabel.DoPaint;
var
  ARect      : TRect;
  ATextStyle : TTextStyle;
begin
  //inherited paint;
  // if FAutoSizing then AutoAdjustSize;
 
  //if FNeededUpdate then
  //begin
  //  //DrawLabel(FBuffer);
  //  DrawCanvasLabel;
  //end;
   ARect:=Rect(0,0,width,height);
  //Canvas.Clear;
 
  // Canvas.Brush.Style:=bsSolid;
   //Canvas.Brush.Style:=bsClear;
   //Canvas.Brush.Color := clNone;
   //Canvas.FillRect(Rect(0, 0, Width, Height));
   //
  ATextStyle.Opaque    := False;
 
 ATextStyle.Alignment  :=taCenter;
 ATextStyle.ShowPrefix := False;
 ATextStyle.Wordbreak  := False;
 ATextStyle.Layout     := tlCenter;
 ATextStyle.Clipping   := False;
 ATextStyle.SystemFont := False;
 
 ATextStyle.RightToLeft:= False;
 ATextStyle.ExpandTabs := False;
 
   ATextStyle.SingleLine  := False;
   ATextStyle.EndEllipsis := False;
 
 Canvas.TextStyle := ATextStyle;
 
  Canvas.TextRect(ARect,0,0,FCaption,ATextStyle);
   //DrawCanvasLabel;
  //{$ifdef FPC}
  //  Fmem.Clear;
  //  FBuffer.SaveToStream(Fmem);
  //  Fmem.Position:=0;
  //  FBuffer.Clear;
  //  FBuffer.FreeImage;
  //  FBuffer.Transparent:=true; // Important à redéclarer sinon pas de transparence
  //  FBuffer.TransparentColor:=clInfobk; // idem ici
  //  FBuffer.LoadFromStream(Fmem);
  //{$endif}
 // Canvas.Draw(0,0, FBuffer);
 
 
end;
//==== PUBLIC ==================================================================
 
{**-----------------------------------------------------------------------------
 * @Name        : Create
 * @Description : Creation de notre bouton personnalisé
 -----------------------------------------------------------------------------**}
constructor TBZCustomLabel.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
 // Self.Parent := TWinControl(AOwner);
 
  ControlStyle := [csCaptureMouse, csClickEvents, csDoubleClicks]-[csOpaque];
 
  Self.Color:=clNone;
  //Self.BorderStyle:=bsNone;
 
  {$ifdef FPC}  Fmem:=TMemoryStream.Create;    {$endif}
 
  FBuffer:=TBitmap.Create;
  FBuffer.SetSize(Self.Width,Self.Height);
  FBuffer.PixelFormat := pf32Bit;
  FBuffer.Transparent := True;
  FBuffer.TransparentColor := clNone;
  FBuffer.Canvas.Brush.Style:=bsSolid;
  FBuffer.Canvas.Brush.Color := clNone;
  FBuffer.Canvas.FillRect(Rect(0, 0, Width, Height));
  FBuffer.Canvas.Brush.Style:=bsClear;
 
  FCaption  := 'BZLabel';
  FAutoSizing := False;
 
  Width         := 75;
  Height        := 25;
 
  FStyle := TBZCaptionStyle.Create(self);
  FStyle.ShowPrefix := False;
  FStyle.SetText(FCaption);
  FStyle.OnChange := @DoChangeStyle;
 
 
  FNeededUpdate:=true;
end;
 
{**-----------------------------------------------------------------------------
 * @Name        : Destroy
 * @Description : Destruction de notre composant
 -----------------------------------------------------------------------------**}
destructor TBZCustomLabel.Destroy;
begin
  FreeAndNil(FStyle);
  FreeAndNil(FBuffer);
  FBackground.free;
  FMem.Free;
  inherited Destroy;
end;
 
 
 
 
end.

ps: Vous pouvez faire abastraction de FStyle c'est juste un containeur de propriétés et de l'unité BZ_Types il n'y a rien dedans concernant l'affichage

A+ et à bientot avec des composants utilisants BRGABitmap

**Jipété** · 08/11/2015, 12h58

Salut,

Envoyé par BeanzMaster

Salut à tous après de grosses prises de tête pour gérer la transparence dans les composants visuels [--snip--]

et encore t'es pas sous Linux !

Parce que dans cet environnement, la transparence (ou pas) dépend du Window Manager (à moins que ça doit le Desktop Manager, à chaque fois je m'y perds), en tout cas, pour porter un projet de Delphi/W2K vers Lazarus/Linux, j'ai bien crû que la machine allait passer par la fenêtre, jusqu'à ce que je réalise, avec l'aide du forum, que la transparence n'était pas toujours au rendez-vous, et que c'était normal !

**BeanzMaster** · 08/11/2015, 17h04

et encore t'es pas sous Linux !

Ouep c'est comme pour les Hotkeys tout dépend si tu est sous Gnome ou Kde par exemples dur de faire un trucs générique.

Le problème ici ce sont vraiment les procédures sur le Canvas qui sont boguées. Les développeur de FPC et Lazarus ont encore du chemin à faire. Car je suis sur allez à 99% que mon code doit fonctionner nickel sous Delphi.
Pour la transparence des TCustomControl il semblerai que les codes incriminés se trouvent dans les classes de type Widgets dont se sert la LCL pour générer l'affichage après en plus tout dépend de l'interface utilisée GTK, Carbon ect.... une vrai prise de tête pour trouver les codent qui gère tout ça. Au moins avec BGRABitmap je réussirai à obtenir de bien meilleurs résultats et ça sera plus simple à gérer en plus

Petit paquet de composants pl_beanz

Lazarus Pascal

Discussions similaires

Partager

Partager