Mimer TStringGrid.OnValidateEntry de Lazarus

Version imprimable

02/10/2018, 16h41
tourlourou

Mimer TStringGrid.OnValidateEntry de Lazarus

Bonjour,

Une petite question, car j'ai de la suite dans les idées, ou de la suite, mais pas d'idées !

Est-il possible d'adjoindre à un TStringGrid un comportement mimant l'événement se produisant en fin d'édition du contenu d'une cellule, permettant au choix de l'utilisateur le retour à la valeur antérieure ou à une valeur arbitraire (comme pour les StringGrid de Lazarus) ?

Sans dériver la classe, sinon, ce serait facile !

J'ai pensé à utiliser des approches suggérées par cette discussion, ou à biaiser comme suggéré ici.

Sinon, je peux envisager d'utiliser un objet qui gèrera des StringGrids qu'on lui aura confiées : il associera l'état de chacun aux événements qu'il en recevra, pour détecter l'entrée en mode édition et la sortie (OnEditingDone mais EditorMode False ?) en détournant leurs événements OnSelectCell et OnEditingDone. Mais est-ce bien propre ?

En dérivant la grille, il suffit de :

Code:

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
  // type natif sous Lazarus, dont les StringGrids permettent la validation de saisie
  TValidateEntryEvent = procedure(Sender: TObject; aCol, aRow: Integer; const aOldValue: string; var aNewValue: String) of Object;
 
  // descendant implémentant les fonctionnalités présentes sous Lazarus
  TdySQliteGrid = class(TStringGrid)
   private
    EditorPrevMode   : Boolean;
    EditorPrevCol    : LongInt;
    EditorPrevRow    : LongInt;
    EditorPrevValue  : string;
    FOnValidateEntry : TValidateEntryEvent;
   protected
    procedure WndProc(var Message: TMessage); override;
   public
    constructor Create(AOwner: TComponent); override;
    procedure Clear;
    property OnValidateEntry : TValidateEntryEvent read FOnValidateEntry write FOnValidateEntry;
  end;
 
//...
 
constructor TdySQliteGrid.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  EditorPrevCol    := Col;
  EditorPrevRow    := Row;
  EditorPrevMode   := False;
  EditorPrevValue  := '';
end;
 
procedure TdySQliteGrid.WndProc(var Message: TMessage);
var
  NewValue : string;
begin
 inherited;
 if EditorMode <> EditorPrevMode then
  begin
    EditorPrevMode := EditorMode;
    if EditorMode then
     begin // entrée dans le mode édition
       EditorPrevCol   := Col;
       EditorPrevRow   := Row;
       EditorPrevValue := Cells[Col, Row];
     end
    else
     begin // sortie du mode édition
       NewValue := Cells[EditorPrevCol, EditorPrevRow];
       if (NewValue <> EditorPrevValue) and Assigned(FOnValidateEntry) then
       begin // demande de validation de la saisie
         FOnValidateEntry(self, EditorPrevCol, EditorPrevRow, EditorPrevValue, NewValue);
         if NewValue <> Cells[EditorPrevCol, EditorPrevRow] then
           Cells[EditorPrevCol, EditorPrevRow] := NewValue; // entrée non validée
       end;
     end;
  end;
end;

mais je trouverais plus simple d'utiliser le type natif...

salut

perso je passerais par le TInplaceEdit

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
 
TStringGrid = Class(Grids.TStringGrid)
    function CreateEditor: TInplaceEdit; Override;
 
   ....
   Property OnEnterEdit ....
   Property OnExitEdit ....
  end;
....
function TStringGrid.CreateEditor: TInplaceEdit;
var
  Scaling : Boolean;
begin
  result := Inherited CreateEditor;
  Result.onEnter := OnEnterEdit;
  Result.onExit    :=OnExitEdit;
end;

Bonjour,
Je n'ai malheureusement pas réussi à l'implémenter de cette façon :
- sous Tokyo 10.2, les événements TInPlaceEDit.OnEnter et OnExit sont protected ;
- en utilisant un transtypage dans une classe de hack les exposant, pas de passage à l'exécution dans les événements affectés !
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 type TMyInplaceEdit = class(Vcl.Grids.TInplaceEdit) public property OnEnter; property OnExit; end; function TMyStringGrid.CreateEditor: TInplaceEdit; begin Result := inherited CreateEditor; TMyInplaceEdit(Result).OnEnter := OnEnterEdit; TMyInplaceEdit(Result).OnExit := OnExitEdit; end;

Bonjour,

le problème n'est pas récent. Sur un autre site dont je tairai le nom j'ai trouvé ce code

Code:

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
...
const
  WM_INPLACEEDIT_EXIT = WM_USER + $100;
 
type
  TStringGridHelper = Class(TStringGrid);
 
...
TForm1 = class(TForm)
...
    procedure FormCreate(Sender: TObject);
    procedure StringGrid1GetEditText(Sender: TObject; ACol, ARow: Integer;
      var Value: String);
    procedure StringGrid1Exit(Sender: TObject);
...
    OldWndProc, NewWndProc: TFarProc;
    hCurrentInplaceEdit: HWND;
    procedure HookInplaceEdit(hw: HWND);
    procedure InplaceEditWndProc(var Message: TMessage);
    procedure UnHookInplaceEdit(hw: HWND);
    procedure InplaceEditOnExit(var Message: TMessage); message WM_INPLACEEDIT_EXIT;
...
 
procedure TForm1.FormCreate(Sender: TObject);
begin
  hCurrentInplaceEdit := 0;
  OldWndProc := nil;
  NewWndProc := nil;
end;
 
procedure TForm1.StringGrid1GetEditText(Sender: TObject; ACol,
  ARow: Integer; var Value: String);
begin
  if Assigned(TStringGridHelper(StringGrid1).InplaceEditor) then
    HookInplaceEdit(TStringGridHelper(StringGrid1).InplaceEditor.Handle);
end;
 
procedure TForm1.StringGrid1Exit(Sender: TObject);
begin
  if Assigned(TStringGridHelper(StringGrid1).InplaceEditor) then
    UnHookInplaceEdit(TStringGridHelper(StringGrid1).InplaceEditor.Handle);
end;
 
procedure TForm1.HookInplaceEdit(hw: HWND);
begin
  if hCurrentInplaceEdit = 0 then
  begin
    OldWndProc := TFarProc(GetWindowLong(hw, GWL_WNDPROC));
    NewWndProc := Classes.MakeObjectInstance(InplaceEditWndProc);
    SetWindowLong(hw, GWL_WNDPROC, LongInt(NewWndProc));
    hCurrentInplaceEdit := hw;
    //SendMessage(Self.Handle, WM_INPLACEEDIT_EXIT, 1, 0);
  end;
end;
 
procedure TForm1.UnHookInplaceEdit(hw: HWND);
begin
  if hCurrentInplaceEdit > 0 then
  begin
    SetWindowLong(hw, GWL_WNDPROC, LongInt(OldWndProc));
    hCurrentInplaceEdit := 0;
    if Assigned(NewWndProc) then
    begin
      Classes.FreeObjectInstance(NewWndProc);
      NewWndProc := nil;
    end;
    //SendMessage(Self.Handle, WM_INPLACEEDIT_EXIT, 2, 0);
  end;
end;
 
procedure TForm1.InplaceEditWndProc(var Message: TMessage);
begin
  //call old proc
  Message.Result := CallWindowProc(OldWndProc, hCurrentInplaceEdit, Message.Msg,
    Message.wParam, Message.lParam);
 
  if Message.Msg = WM_KILLFOCUS then
  begin
    PostMessage(Self.Handle, WM_INPLACEEDIT_EXIT, 0, MakeLong(StringGrid1.Col, StringGrid1.Row));
  end;
end;
 
procedure TForm1.InplaceEditOnExit(var Message: TMessage);
begin
  if Message.WParam = 0 then
  begin
    StringGrid1.Cells[Message.LParamLo, Message.LParamHi] := '111';
  end;
end;

Ce que j'aime c'est qu'il ne nécessite aucun développement de composant à vérifier si cela fonctionne et peut convenir

04/10/2018, 17h45
tourlourou

Merci, Serge ; à étudier et adapter au besoin. Ce ne sera pas immédiat !

Ça ne l'a en effet pas été ! Je n'ai pas réussi à le faire fonctionner convenablement tel quel.

Mais en mixant mes essais issus de différentes approches, j'obtiens ce que je souhaitais :

Code:

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
unit Unit3;
 
// https://stackoverflow.com/questions/5055811/how-can-i-detect-when-a-user-is-finished-editing-a-tstringgrid-cell
 
// https://www.developpez.net/forums/d1899042/environnements-developpement/delphi/composants-vcl/mimer-tstringgrid-onvalidateentry-lazarus/#post10515665
 
// https://www.experts-exchange.com/questions/28713957/Event-leaving-a-cell-in-a-TStringGrid.html
 
interface
 
uses
  Vcl.Grids, Winapi.Windows, Winapi.Messages, System.Classes;
 
type
  TOnValidateEntry = procedure(Sender: TObject; aCol, aRow: Integer; const aOldValue: String; var aNewValue: String) of Object;
 
  TStringGridMessageObserver = class
   private
    FGrid: TStringGrid;
    hGrid: HWND;
    OldWndProc, NewWndProc: TFarProc;
    FOnValidateEntry: TOnValidateEntry;
    OldValue: string;
    PrevCol, PrevRow: LongInt;
    PreviousMode: Boolean;
    procedure HookGridMessages(hw: HWND);
    procedure NewGridWndProc(var Message: TMessage);
    procedure UnHookGridMessages(hw: HWND);
   public
    constructor Create;
    destructor Destroy; override;
    function AddStringGridValidationMethod(aGrid: TStringGrid; aOnValidateEntry: TOnValidateEntry): Boolean;
  end;
 
implementation
 
constructor TStringGridMessageObserver.Create;
begin
  FOnValidateEntry := nil;
  OldWndProc := nil;
  NewWndProc := nil;
  FGrid := nil;
  hGrid := 0;
  PreviousMode := False;
  OldValue := '';
  PrevCol := -1;
  PrevRow := -1;
end;
 
function TStringGridMessageObserver.AddStringGridValidationMethod(aGrid: TStringGrid; aOnValidateEntry: TOnValidateEntry): Boolean;
begin
  Result := False;
  if not Assigned(FGrid) and (aGrid is TStringGrid) and Assigned(aOnValidateEntry) then
  begin
    FOnValidateEntry := aOnValidateEntry;
    FGrid := aGrid;
    HookGridMessages(aGrid.Handle);
    Result := True;
  end;
 
end;
 
procedure TStringGridMessageObserver.HookGridMessages(hw: HWND);
begin
    OldWndProc := TFarProc(GetWindowLong(hw, GWL_WNDPROC));
    NewWndProc := MakeObjectInstance(NewGridWndProc);
    SetWindowLong(hw, GWL_WNDPROC, LongInt(NewWndProc));
    hGrid := hw;
end;
 
procedure TStringGridMessageObserver.NewGridWndProc(var Message: TMessage);
var
  GridIsEditing: Boolean;
  NewValue: string;
begin
  // appel au traitement de base de la grille
 Message.Result := CallWindowProc(OldWndProc, hGrid, Message.Msg, Message.wParam, Message.lParam);
 
 GridIsEditing := FGrid.EditorMode;
 
 if GridIsEditing <> PreviousMode then
  begin
    PreviousMode := GridIsEditing;
    with FGrid do
    if GridIsEditing then
     begin // entrée dans le mode édition
       PrevCol   := Col;
       PrevRow   := Row;
       OldValue  := Cells[Col, Row];
     end
    else
     begin // sortie du mode édition
       NewValue := Cells[PrevCol, PrevRow];
       if (NewValue <> OldValue) and Assigned(FOnValidateEntry) then
       begin // demande de validation de la saisie
         FOnValidateEntry(FGrid, PrevCol, PrevRow, OldValue, NewValue);
         if NewValue <> Cells[PrevCol, PrevRow] then
           Cells[PrevCol, PrevRow] := NewValue; // entrée non validée
       end;
     end;
  end;
 end;
 
procedure TStringGridMessageObserver.UnHookGridMessages(hw: HWND);
begin
  if hGrid = hw then
  begin
    SetWindowLong(hw, GWL_WNDPROC, LongInt(OldWndProc));
    hGrid := 0;
    if Assigned(NewWndProc) then
    begin
      FreeObjectInstance(NewWndProc);
      NewWndProc := nil;
    end;
  end;
end;
 
destructor TStringGridMessageObserver.Destroy;
begin
  UnHookGridMessages(hGrid);
  inherited;
end;
 
end.

Et il suffit de l'appeler comme ceci :

Code:

1
2
  StringGridMessageObserver := TStringGridMessageObserver.Create;
  StringGridMessageObserver.AddStringGridValidationMethod(StringGrid1, MyOnValidateEntry);

pour adjoindre à une grille le déclenchement d'une callback en fin d'édition d'une cellule.

Bien évidemment, ceci n'est pê pas portable ailleurs que sous Windows, mais c'est natif sous Lazarus pour Linux.