Fusionner des cellules dans stringgrid

**CharleLéo** · 30/01/2009, 12h09

Bonjour à tous,

Je me suis inspiré du post http://www.developpez.net/forums/d32...ellules-fixes/

Le problème est lorsque je fais un scroll dans le StringGrid, les cellules fusionnées, ne le sont plus.

Mon idée est que lorsque le scroll est terminé, il faudrait redessinner le stringGrid. Comment ?

Qu'en pensez vous.

A+

**BuzzLeclaire** · 30/01/2009, 13h27

Tu as essayer de gere depuis les evenement de ton StringGrid

Code :

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

1
2
3
4
5
procedure TFormPrincipal.StringGridSMouseWheelDown(Sender: TObject;
  Shift: TShiftState; MousePos: TPoint; var Handled: Boolean);
begin
  invalidate;
end;

Code :

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

1
2
3
4
5
procedure TFormPrincipal.StringGridSemaineMouseWheelUp(Sender: TObject;
  Shift: TShiftState; MousePos: TPoint; var Handled: Boolean);
begin
   Invalidate;
end;

ou mieux créer ton composant :

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
 
// Créer par AndNotOr (forum Develloppez.com
// Ici modifier...
 
uses
  SysUtils, Classes, Controls, Grids, Messages, Windows;
 
type
 
  TStringGridx = class(TStringGrid)
  private
    { Déclarations privées }
  protected
    { Déclarations protégées }
     procedure WMVSCROLL(var Message :TMessage); message WM_VSCROLL;
     procedure WMMOUSEWHEEL(var Message :TMessage); message WM_MOUSEWHEEL;
  public
    { Déclarations publiques }
  published
    { Déclarations publiées }
  end;
 
procedure Register;
 
implementation
 
 
procedure  TStringGridx.WMVSCROLL(var Message :TMessage);
begin
  inherited;
  Invalidate;
end;
 
procedure TStringGridx.WMMOUSEWHEEL(var Message: TMessage);
begin
  inherited;
  Invalidate;
end;
 
procedure Register;
begin
  RegisterComponents('Compoperso', [TStringGridx]);
end;
end.

**ero-sennin** · 30/01/2009, 13h31

Salut,

A tous hasard, as-tu regarder l'entrée dans la FAQ ?

A+

**CharleLéo** · 30/01/2009, 19h52

Re,

J'étais absent cette aprés midi. J'ai essauyé avec les évènements de la souris : idem.

Dans la FAQ RAS.

Par contre, je vais essayer de mettre une condition dans le DrawCell, du style :
if acol>1 then ...

Je reviendrai pour vous dire
A+

**CharleLéo** · 02/02/2009, 19h44

je pense qu'il faut tester le leftcol su stringgrid au moment de l'évènement TopLeftChanged(Sender: TObject)

Qu'en pensez vous?
Quelqu'un a t'il une piste?

A+

**anapurna** · 04/02/2009, 18h40

salut

en derivant simplement les evenement de la stringGrid tu devrais pouvoir t'en sortir

voici un exemple qui me parait fonctionner si tu trouve une erreur dit le moi

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
 
unit UTestEdit;
 
interface
 
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ComCtrls, Grids;
 
type
 
  TStringGrid = Class(Grids.TStringGrid)
    procedure WMSize(var Msg: TWMSize); message WM_SIZE;
    procedure WMHScroll(var Msg: TWMHScroll); message WM_HSCROLL;
  end;
 
  TForm1 = class(TForm)
    StrGrid: TStringGrid;
    procedure FormCreate(Sender: TObject);
    procedure StrGridDrawCell(Sender: TObject; ACol, ARow: Integer;
      Rect: TRect; State: TGridDrawState);
  private
    { Déclarations privées }
  public
    Poscur : Cardinal;
    { Déclarations publiques }
  end;
 
var
  Form1: TForm1;
 
implementation
uses ExtCtrls;
 
{$R *.dfm}
 
procedure TStringGrid.WMSize(var Msg: TWMSize);
begin
 DefaultHandler(Msg);
 Invalidate;
end;
procedure TStringGrid.WMHScroll(var Msg: TWMHScroll);
begin
 DefaultHandler(Msg);
 Invalidate;
end;
 
 
procedure TForm1.FormCreate(Sender: TObject);
begin
 
  StrGrid.ColWidths[0] := 22;
  StrGrid.Cells[1,0] := 'Entités';
  StrGrid.Cells[2,0] := 'Données évaluées';
  StrGrid.Cells[3,0] := '';
  StrGrid.Cells[4,0] := 'Erreurs évaluées';
  StrGrid.Cells[5,0] := '';
  StrGrid.Cells[2,1] := 'Valeur';
  StrGrid.Cells[3,1] := 'Pertinence';
  StrGrid.Cells[4,1] := 'Valeur';
  StrGrid.Cells[5,1] := 'Pertinence'
end;
 
const
  TXT_MARG: TPoint = (x: 4; y: 2);
 
    Procedure  DrawButton(Grid : TStringGrid;rect : TRect;Fin : boolean);
    var
      OldBrushStyle : TBrushStyle ;
      OldPenStyle   : TPenStyle;
    begin
      OldBrushStyle :=  Grid.Canvas.Brush.Style ;
      OldPenStyle   :=   Grid.Canvas.Pen.Style ;
      Grid.Canvas.Brush.Style := bsClear;
      Grid.Canvas.FillRect(rect);
      Frame3D(Grid.Canvas,Rect,clWhite,clBtnShadow,1);
      Grid.Canvas.Brush.Style := OldBrushStyle;
      Grid.Canvas.Pen.Style   := OldPenStyle ;
    end;
 
    Procedure  OwnerDrawText(Grid : TStringGrid;rect : Trect;Texte : String;UFormat : Cardinal );
    var
      OldBrushStyle : TBrushStyle ;
      OldPenStyle   : TPenStyle;
    begin
      Rect.Left := Rect.left + TXT_MARG.x;
      OldBrushStyle :=  Grid.Canvas.Brush.Style ;
      OldPenStyle   :=  Grid.Canvas.Pen.Style ;
      Grid.Canvas.Brush.Style := bsClear;
      Grid.Canvas.Pen.Style := psClear;
      DrawText(Grid.Canvas.Handle,PChar(Texte), -1, Rect ,UFormat);
      Grid.Canvas.Brush.Style := OldBrushStyle;
      Grid.Canvas.Pen.Style := OldPenStyle ;
    end;
 
    Function MergingCell(Sender: TObject;Rect: TRect;Coldeb,RowDeb,ColFin,RowFin : integer;aCol,ARow : Integer;State: TGridDrawState) : boolean;
    var
      txtRect: TRect;
      str : String;
      Grid : TStringGrid;
      OldBrushStyle : TBrushStyle ;
      OldPenStyle   : TPenStyle;
      OldRect : Trect;
    begin
      Grid := (Sender as TStringGrid);
      Result  := False;
      OldRect := Rect;
 
      if Coldeb < 0 then Coldeb := 0;
      if ColFin > pred(Grid.ColCount) then ColFin := pred(Grid.ColCount);
      if RowDeb < 0 then RowDeb := 0;
      if RowFin > pred(Grid.RowCount) then RowFin := pred(Grid.RowCount);
 
     If     (ARow in [RowDeb..RowFin])
      and  (aCol in [Coldeb..ColFin]) Then
      begin
 
        Grid.Canvas.FillRect(Rect);
        Rect.Left   := Grid.CellRect(ColDeb,RowDeb).Left;
        Rect.Top    := Grid.CellRect(ColDeb,RowDeb).Top;
        Rect.Right  := Grid.CellRect(ColFin,RowFin).Right;
        Rect.Bottom := Grid.CellRect(ColFin,RowFin).Bottom;
 
        str := Grid.Cells[ColDeb, RowDeb];
        if Grid.VisibleColCount < colFin Then
        begin
          if Grid.Canvas.TextWidth(str) > (Rect.Right-Rect.Left) Then
          begin
            str := Grid.Cells[ACol,ARow];
            Rect := OldRect;
          end;
        end;
        DrawButton(Grid,Rect,aCol = Grid.ColCount);
 
        txtRect := Rect;
        str := Grid.Cells[ColDeb, RowDeb];
        if Grid.VisibleColCount < colFin Then
        begin
          if Grid.Canvas.TextWidth(str) > (Rect.Right-Rect.Left) Then
          begin
            str := Grid.Cells[ACol,ARow];
            txtRect := OldRect;
          end;
        end;
        OwnerDrawText(Grid,txtRect,str,DT_SINGLELINE or DT_CENTER or DT_VCENTER or DT_EDITCONTROL);
        Result := true;
      end;
   end;
 
 
 
 
procedure TForm1.StrGridDrawCell(Sender: TObject; ACol, ARow: Integer;
  Rect: TRect; State: TGridDrawState);
var
  OldBrushStyle : TBrushStyle ;
  OldPenStyle   : TPenStyle;
  Grid : TStringGrid;
begin
   Grid := (sender as TStringGrid);
   if not MergingCell(Grid ,Rect,2,0,3,0,ACol,ARow,State)then
     if not MergingCell(Grid ,Rect,4,0,5,0,ACol,ARow,State)then
      if not MergingCell(Grid ,Rect,5,1,6,1,ACol,ARow,State) then
   begin
      Grid.Canvas.FillRect(rect);
      DrawButton(Grid,rect,aCol = Grid.ColCount);
      OwnerDrawText(Grid ,rect,Grid.Cells[ACol,ARow], DT_SINGLELINE  or DT_CENTER or DT_VCENTER or DT_EDITCONTROL);
    end;
 
  if Grid.VisibleColCount < Grid.ColCount Then
    ShowScrollBar(Grid.Handle,SB_HORZ,true);
end;
 
end.

**CharleLéo** · 05/02/2009, 09h11

Salut,

Anapurna, j'ai essayé ton code, le scroll ne fonctionne pas. Ce qui se passe :

L'édition de la cellule la plus à droite dans la ligne, équivaut à un scroll vers la droite (impec). Par contre, impossible de faire un scroll vers la gauche.
le stringgrid reste figé.

J'ai recopié tel quel ton code, sans essayer de le comprendre.
A au fait, j'ai mis la propriété defautdrawing du stringgrid à false.

Donc je vais maintenant y jeter un oeil.

A+

**anapurna** · 05/02/2009, 16h42

salut

effectivement je n'est pas tester le scrolling est
... il marche pas

faut que je comprenne ce qui ce passe ?
sinon le reste te convient ?

moi je lai tester avec le defaultdrawing à true
mais dans les option j'ai viré gofixedvertline ...goHorzline

une petite erreur c'est intercalé
dans la methode DrawCell
il faut remplacer ce code

Code :

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

1
2
if Grid.VisibleColCount < Grid.ColCount Then
    ShowScrollBar(Grid.Handle,SB_HORZ,true);

par

Code :

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

1
2
3
4
if Grid.VisibleColCount < pred(Grid.ColCount) Then
    ShowScrollBar(Grid.Handle,SB_HORZ,true)
  else
    ShowScrollBar(Grid.Handle,SB_HORZ,False)

@+ Phil

PS : reste que l'histoire du scrolling

[EDIT] j'ai trouver remplace dans les message

Code :

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

DefaultHandler

par

Code :

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

inherited ;

@+ Phil

**CharleLéo** · 05/02/2009, 17h51

j'ai essayé de poster mon code, mais j n'arrive pas à le tabuler correctement pour qu'il soit lisible.

En attendant que je trouve comment, je joint les copies d'écran.

A+

PS : le scroll horizontal c'est ok, pas le vertical, il semble que "VAC 1" soit à nouveau écrit!

**anapurna** · 05/02/2009, 18h40

salut

a modifier

Code :

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

1
2
3
4
5
6
7
8
9
10
 
if (Grid.VisibleColCount < colFin) or (Grid.VisibleRowCount < RowFin) Then
        begin
          if (Grid.Canvas.TextWidth(str) > (Rect.Right-Rect.Left)) or 
            (Grid.Canvas.Textheigth(str) > (Rect.top-Rect.bottom))Then
          begin
            str := Grid.Cells[ACol,ARow];
            txtRect := OldRect;
          end;
        end;

pas le temps de tester le code mais ca doit etre ici que cela peche

@+ Phil

**CharleLéo** · 05/02/2009, 20h06

Salut,
Voilà aprés 20 minutes pour mettre en forme mon code :

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
procedure TFormPlanning.PlanningDrawCell(Sender: TObject; ACol, ARow: Integer;
Rect: TRect; State: TGridDrawState);
var
OldBrushColor:Tcolor;
OldFontSize:integer;
begin
  with Sender as TStringGrid do
    begin
      OldBrushColor:=Canvas.Brush.color;
      OldFontSize:=Canvas.font.height;
      Canvas.font.Name:='calibri';
      Canvas.Font.size:=10;
      OldFontSize:=Canvas.font.height;
      if gdFixed in State then // Si cellule fixe
       begin
         if (not MergedCells(Planning,Acol,Arow,0,0,1,1,state) and not 
         mergedcells(Planning,Acol,Arow,2,0,4,0,state)
         and not mergedcells(Planning,Acol,Arow,0,2,0,5,state) and not  
         mergedcells(Planning,Acol,Arow,0,6,0,10,state))
         then
           begin // Si cellule fixe pas fusionnée :
             if (aRow=0) and (aCol>4) then // titre colonne
               begin
                 Canvas.brush.Color:=claqua;
                 // Le bloc qui suit pour imiter le "look" par défaut
                 if GridLineWidth = 1 then
                   begin
                     Canvas.Pen.Color := clBlack;
                     Canvas.Pen.Width := 1;
                     Canvas.Rectangle(Rect.Left-1,Rect.Top-1,Rect.Right+1,
                     Rect.Bottom+1);
                   end;
                 FillRect(Canvas.Handle,Rect,Canvas.Brush.Handle);
                 Frame3D(Canvas, Rect, clBtnHighlight, clBtnShadow,  
                 BevelWidth);
                 InflateRect(Rect,-2,-2);
                 DrawText(Canvas.Handle, PChar(Cells[ACol,ARow]),-1,     
                 Rect ,DT_CENTER or DT_NOPREFIX or DT_VCENTER or  
                 DT_SINGLELINE );
                 Canvas.Brush.color:=OldBrushColor;
             end
           else
             begin
               if ((acol in [2..4]) and (Arow=1)) then
                 begin
                   Canvas.brush.color:=$00B0FFB0;
                   Canvas.Font.size:=7;
                   Canvas.Rectangle(Rect.Left-1,Rect.Top-1,Rect.Right+1,
                   Rect.Bottom+1);
                   DrawText(Canvas.Handle, PChar(Cells[ACol,ARow]),-1,  
                   Rect ,DT_CENTER or DT_NOPREFIX or DT_VCENTER or 
                   DT_SINGLELINE );
                   Canvas.font.height:=OldFontSize;
                 end
               else
                 begin
                   Canvas.brush.Color:=clwindow;
                   Canvas.Pen.Color := clSilver;
                   Canvas.Pen.Width := 1;
                   Canvas.Rectangle(Rect.Left-1,Rect.Top-1,Rect.Right+1,
                   Rect.Bottom+1);
                   DrawText(Canvas.Handle, PChar(Cells[ACol,ARow]),-1, 
                   Rect ,DT_CENTER or DT_NOPREFIX or DT_VCENTER or 
                   DT_SINGLELINE );
                end;
             end;
           end;
       end
     else
      DrawText(Canvas.Handle, PChar(Cells[ACol,ARow]),-1, Rect ,DT_CENTER 
      or DT_NOPREFIX or DT_VCENTER or DT_SINGLELINE );
   end;
end; 
 
unit CellFusFaqDev_com;
 
interface
 
uses  Windows, Messages, SysUtils, Classes, Graphics, Controls,
	Grids, StdCtrls,extctrls;
 
	function MergedCells(Planning:TStringGrid; ACol,ARow,ACol1,ARow1,ACol2,ARow2:Integer; ACurrentState: TGridDrawState):Boolean;
 
implementation
 
function MergedCells(Planning:TStringGrid; ACol,ARow,ACol1,ARow1,ACol2,ARow2:Integer; ACurrentState: TGridDrawState):Boolean;
var
  x1,y1,x2,y2:Integer;
  Rect:TRect;
begin
 with Planning, Canvas do
  begin
   //Initialisations diverses
   Rect := Bounds(0,0,0,0);
   x1 := ACol1;
   y1 := ARow1;
   x2 := ACol2;
   y2 := ARow2;
   result := false;
 
   //On vérifie que la zone fusionnée est valide
   if x1 < 0 then x1 := 0;
   if x2 > ColCount-1 then x2 := ColCount-1;
   if y1 < 0 then y1 := 0;
   if y2 > RowCount-1 then y2 := RowCount-1;
 
   if (x1 > x2) or (y1 > y2) then
    begin
      result := false;
      exit;
    end;
 
   //Si la cellule courante est la dernière de la zone de fusion, on dessine dans la fusion le texte de la cellule en haut à gauche
   if ((ACol=ACol2) {and (ARow=ARow2)}) then
    begin
     Rect.Left := CellRect(ACol1,ARow1).Left;
     Rect.Top := CellRect(ACol1,ARow1).Top;
     Rect.Right := CellRect(aCol2,ARow2).Right;
     Rect.Bottom := CellRect(aCol2,ARow2).Bottom;
     brush.Color:=clyellow;
    // FillRect(Rect);
     // Le bloc qui suit pour imiter le "look" par défaut
     if GridLineWidth = 1 then
      begin
       Pen.Color := clblack;
       Pen.Width := 1;
       Canvas.Rectangle(Rect.Left-1,Rect.Top-1,Rect.Right,Rect.Bottom+1);
      end;
     //
     Frame3D(Canvas, Rect, clBtnHighlight, clBtnShadow, 1);
     InflateRect(Rect,-2,-2);
     DrawText(Handle, PChar(Cells[ACol1,ARow1]),-1, Rect ,DT_CENTER or DT_NOPREFIX or DT_VCENTER or DT_SINGLELINE  );
    end;
 
   //Si la cellule courante est dans la zone de fusion, on dit qu'on la dessiné (même si ce n'est pas vrai :) )
   if ((ACol>=ACol1) and (ARow>=ARow1) and (ACol<=ACol2) and (ARow<=ARow2)) then
   	begin
     //DrawText(Handle, PChar(Cells[ACol1,ARow1]), -1, Rect ,DT_CENTER or DT_NOPREFIX or DT_VCENTER or DT_SINGLELINE );
    	result := True;
    end;
 
  end;
 
end;
 
end.

j'ai juste modifié dans l'unité MergedCells( :

Code :

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

if ((ACol=ACol2) {and (ARow=ARow2)}) then

voilà vous avez tout, le scroll horizontal fonctionne, le scroll vertical ne focntionne pas comme je voudrais.
A propos, si je fais monter le scroll d'un seul coup vers le haut (sans lacher la souris), là je n'ai pas de pb d'affichage.....
Pour anapurna : pour le scroll horizontal , j'ai utilisé fixedcol

Là, j'en ai marre, avec ce scroll vertical
j'ai pas du tout comprendre dans la fonction mergecell même en ayant viré un bout de code

A+

**CharleLéo** · 16/02/2009, 17h06

Salut tout le monde,

Donc je reviens simplement pour vous dire, que j'apercois la fin du tunnel.

En effet, j'arrive à scroller dans mon stringgrid vers le bas. L'idée que j'ai retenue, est la suivante :

a chque scroll donc à chaque évènement onTopLeftChanged de ma stringgrid, je redessine mes rectangle de la colonne 0, en les faisant remonter vers le haut.

A l'heure actuelle, j'initialise le nombre de rectangle à dessiner dans ma colonne 0, le nombre de ligne des rectangles est constant. Cela fonctionne parfaitement.
Je réflechis pour le scroll haut

Seul petit problème, dont je viens de me rendre compte, est que si je déplace la form de mon appli à l'éxécution, le contenu des cellules de ma stringgrid s'éfface!!
Une petite idée?

A+

**anapurna** · 17/02/2009, 13h08

salut

il restera peut etre des evenements a trapper .

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
 
 TStringGrid = Class(Grids.TStringGrid)
    procedure WMSize(var Msg: TWMSize); message WM_SIZE;
    procedure WMHScroll(var Msg: TWMHScroll); message WM_HSCROLL;
    procedure WMVSCROLL(var Msg: TWMvScroll); message WM_VSCROLL;
    procedure WMMOUSEWHEEL(var msg: TMessage); message WM_MOUSEWHEEL;
  end;
 
...
implementation
procedure TStringGrid.WMSize(var Msg: TWMSize);
begin
 inherited;
 Invalidate;
end;
procedure TStringGrid.WMHScroll(var Msg: TWMHScroll);
begin
 inherited;
 Invalidate;
end;
 
procedure TStringGrid.WMVSCROLL(var Msg: TWMvScroll);
begin
 inherited;
 Invalidate;
end;
 
procedure TStringGrid.WMMOUSEWHEEL(var msg: TMessage);
begin
 inherited;
 Invalidate;
end;
 
const
  TXT_MARG: TPoint = (x: 4; y: 2);
 
 
    Procedure  DrawButton(Grid : TStringGrid;rect : TRect;Fin : boolean);
    var
      OldBrushStyle : TBrushStyle ;
      OldPenStyle   : TPenStyle;
    begin
      OldBrushStyle :=  Grid.Canvas.Brush.Style ;
      OldPenStyle   :=   Grid.Canvas.Pen.Style ;
      Grid.Canvas.Brush.Style := bsClear;
      Grid.Canvas.FillRect(rect);
      Frame3D(Grid.Canvas,Rect,clWhite,clBtnShadow,1);
      Grid.Canvas.Brush.Style := OldBrushStyle;
      Grid.Canvas.Pen.Style   := OldPenStyle ;
    end;
 
 
 
    Procedure  OwnerDrawText(Grid : TStringGrid;rect : Trect;Texte : String;UFormat : Cardinal );
    var
      OldBrushStyle : TBrushStyle ;
      OldPenStyle   : TPenStyle;
    begin
      Rect.Left := Rect.left + TXT_MARG.x;
      OldBrushStyle :=  Grid.Canvas.Brush.Style ;
      OldPenStyle   :=  Grid.Canvas.Pen.Style ;
      Grid.Canvas.Brush.Style := bsClear;
      Grid.Canvas.Pen.Style := psClear;
      DrawText(Grid.Canvas.Handle,PChar(Texte), -1, Rect ,UFormat);
      Grid.Canvas.Brush.Style := OldBrushStyle;
      Grid.Canvas.Pen.Style := OldPenStyle ;
    end;
 
    Function MergingCell(Sender: TObject;Rect: TRect;Coldeb,RowDeb,ColFin,RowFin : integer;aCol,ARow : Integer;State: TGridDrawState) : boolean;
    var
      txtRect: TRect;
      str : String;
      Grid : TStringGrid;
      OldBrushStyle : TBrushStyle ;
      OldPenStyle   : TPenStyle;
      OldRect : Trect;
    begin
      Grid := (Sender as TStringGrid);
      Result  := False;
      OldRect := Rect;
 
      Coldeb := max(Coldeb,0);
      ColFin := min(ColFin , pred(Grid.ColCount));
      RowDeb := max(RowDeb,0);
      RowFin := Min(RowFin,pred(Grid.RowCount));
 
       If  (ARow in [RowDeb..RowFin])
      and  (aCol in [Coldeb..ColFin]) Then
      begin
        Grid.Canvas.FillRect(Rect);
        Rect.Left   := Grid.CellRect(ColDeb,RowDeb).Left;
        Rect.Top    := Grid.CellRect(ColDeb,RowDeb).Top;
        Rect.Right  := Grid.CellRect(ColFin,RowFin).Right;
        Rect.Bottom := Grid.CellRect(ColFin,RowFin).Bottom;
 
        str := Grid.Cells[ColDeb, RowDeb];
        if Grid.VisibleColCount < colFin Then
        begin
          if Grid.Canvas.TextWidth(str) > (Rect.Right-Rect.Left) Then
          begin
            str := Grid.Cells[ACol,ARow];
            Rect := OldRect;
          end;
        end;
        DrawButton(Grid,Rect,aCol = Grid.ColCount);
 
        txtRect := Rect;
        str := Grid.Cells[ColDeb, RowDeb];
        if (Grid.VisibleColCount < colFin) or (Grid.VisibleRowCount < RowFin) Then
        begin
          if (Grid.Canvas.TextWidth(str) > (Rect.Right-Rect.Left)) or
            (Grid.Canvas.TextHeight(str) > (Rect.top-Rect.bottom))Then
          begin
            str := Grid.Cells[ACol,ARow];
            txtRect := OldRect;
          end;
        end;
        OwnerDrawText(Grid,txtRect,str,DT_SINGLELINE or DT_CENTER or DT_VCENTER or DT_EDITCONTROL);
        Result := true;
      end;
   end;
 
procedure TForm1.FormCreate(Sender: TObject);
Var Abitmap : Tbitmap;
begin
  StrGrid.ColWidths[0]:= 54;
  StrGrid.Cells[0,0]  := 'EQUIPE';
  StrGrid.Cells[1,0]  := '';
  StrGrid.Cells[2,0]  := 'Compteurs';
  StrGrid.Cells[3,0]  := '';
  StrGrid.Cells[4,0]  := '';
  StrGrid.Cells[2,1]  := 'C';
  StrGrid.Cells[3,1]  := 'RP';
  StrGrid.Cells[4,1]  := 'RU';
 
  StrGrid.Cells[5,0]  := 'jeu 1';
  StrGrid.Cells[6,0]  := 'ven 2';
  StrGrid.Cells[7,0]  := 'sam 3';
  StrGrid.Cells[8,0]  := 'dim 4';
  StrGrid.Cells[9,0] := 'lun 5';
  StrGrid.Cells[10,0] := 'mar 6';
  StrGrid.Cells[11,0] := 'mer 7';
 
  StrGrid.Cells[0,2]  := 'Vac1';
  StrGrid.Cells[0,6]  := 'Vac2';
end;
 
procedure TForm1.StrGridDrawCell(Sender: TObject; ACol, ARow: Integer;
  Rect: TRect; State: TGridDrawState);
var
  OldBrushStyle : TBrushStyle ;
  OldPenStyle   : TPenStyle;
  Grid : TStringGrid;
begin
   Grid := (sender as TStringGrid);
   if not MergingCell(Grid ,Rect,0,0,1,1,ACol,ARow,State)then
   if not MergingCell(Grid ,Rect,2,0,4,0,ACol,ARow,State)then
   if not MergingCell(Grid ,Rect,0,2,1,5,ACol,ARow,State)then
   if not MergingCell(Grid ,Rect,0,6,1,10,ACol,ARow,State)then
   begin
      Grid.Canvas.FillRect(rect);
      DrawButton(Grid,rect,aCol = Grid.ColCount);
      OwnerDrawText(Grid ,rect,Grid.Cells[ACol,ARow], DT_SINGLELINE  or DT_CENTER or DT_VCENTER or DT_EDITCONTROL);
    end;
end;

@+ Phil

**CharleLéo** · 17/02/2009, 13h25

Salut,

je suis en train de m'occuper du scroll lorsque la fleche haut du TStringGrid est clické.

Dés que j'ai terminé, je me pencherais sur les messages sipplémentaires à Trapper.

J'ai changé de piste pour le scroll vertical. J'utilise dans le onTopLeftChanged la propriété StringGrid.topRow, pour dessiner les cellules fusionnées.

Lorsque ce sera enfin terminé, il serait peut être interressant de transformer tout ça en composant. De plus, j'ai trouvé un composant XSTRINGGRID permettant d'afficher à chaque click dans une cellule soit un combo, un mémo.

Plein d'idée que je vais surement approfondir.

A+

**anapurna** · 20/02/2009, 16h57

salut

voila le résultat de mes recherches

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
 
type
 
  TMergeCell = class(TObject)
  public
    Block    : TGridRect;
    Caption  : string;
    Color    : TColor;
    Font     : TFont;
    constructor Create;
    destructor Destroy; override;
  end;
 
  TStringGrid = Class(Grids.TStringGrid)
    Mergeds       : Tlist;
    procedure WMSize(var Msg: TWMSize); message WM_SIZE;
    procedure WMHScroll(var Msg: TWMHScroll); message WM_HSCROLL;
    procedure WMVSCROLL(var Msg: TWMvScroll); message WM_VSCROLL;
    procedure WMMOUSEWHEEL(var msg: TMessage); message WM_MOUSEWHEEL;
    function GetIsMergeCell(acol,arow : integer) : boolean;
    Procedure ClearMergeCells;
    function AddMergeCells(const coldeb, rowdeb, colfin, rowfin: Integer; ACaption: string;Color : TColor): TMergeCell;
    function GetMergeCell(Index : integer) : TMergeCell;
    Procedure SetMergeCell(Index : integer;Value : TMergeCell);
    procedure DrawCell(ACol, ARow: Longint; ARect: TRect;AState: TGridDrawState); override;
 
    Procedure DrawMergeCells(ACol, ARow: Longint; ARect: TRect;AState: TGridDrawState);
    procedure DrawRowButton (Rect: TRect; Text: String; Style: TFontStyles; Alignment: TAlignment);
    procedure DrawCellButton(Rect: TRect; Text: String; Style: TFontStyles; State: TGridDrawState; Alignment: TAlignment);
 
  public
    function GetMergeColRowCell(acol,arow : integer) : TMergeCell;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property MergeCell[Index: Integer] : TMergeCell read GetMergeCell write SetMergeCell;
    property IsMergeCell[aCol,Arow : integer] : Boolean read GetIsMergeCell ;
  end;
 
  TForm1 = class(TForm)
    StrGrid: TStringGrid;
  procedure FormCreate(Sender: TObject);
  private
    { Déclarations privées }
  public
  end;
 
var
  Form1: TForm1;

ensuite l'implementation

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
 
implementation
uses ExtCtrls,Math;
constructor TMergeCell.Create;
begin
  inherited Create;
  Font := TFont.Create;
end;
 
destructor TMergeCell.Destroy;
begin
  Font.Free;
  inherited Destroy;
end;
 
Destructor TStringGrid.Destroy;
begin
  ClearMergeCells;
  Mergeds.Free;
  inherited;
end;
Constructor  TStringGrid.Create;
begin
  inherited;
  DefaultDrawing := false;
  Mergeds := TList.Create;
end;
 
procedure TStringGrid.ClearMergeCells;
var
  x : integer;
begin
  for x := 0 to Pred(Mergeds.Count) do
    TMergeCell(Mergeds[x]).Free;
  Mergeds.Clear;
end;
procedure TStringGrid.WMSize(var Msg: TWMSize);
begin
 inherited;
 Invalidate;
end;
procedure TStringGrid.WMHScroll(var Msg: TWMHScroll);
begin
 inherited;
 Invalidate;
end;
procedure TStringGrid.WMVSCROLL(var Msg: TWMvScroll);
begin
 inherited;
 Invalidate;
end;
procedure TStringGrid.WMMOUSEWHEEL(var msg: TMessage);
begin
 inherited;
 Invalidate;
end;
 
function TStringGrid.AddMergeCells(const colDeb, rowdeb, colFin, rowfin: Integer; ACaption: string;Color : TColor): TMergeCell;
begin
  Result := TMergeCell.Create;
  Result.Font.Assign(Font);
  Result.Color := Color;
  Result.Caption := ACaption;
  Result.Block.Left    := Min(coldeb,colfin);
  Result.Block.Top     := Min(rowdeb,rowfin);
  Result.Block.Right   := Max(coldeb,colfin);
  Result.Block.Bottom  := Max(rowdeb,rowfin);
  Mergeds.Add(Result);
  Invalidate;
end;
 
function TStringGrid.GetIsMergeCell(acol,arow : integer) : boolean;
var
 i : integer;
begin
  Result := False;
  i := 0;
  while (i <= Pred(Mergeds.Count)) and not(Result) do
  begin
    if ( acol in [TMergeCell(Mergeds[i]).Block.Left..TMergeCell(Mergeds[i]).Block.Right])  And
       ( arow in [TMergeCell(Mergeds[i]).Block.Top..TMergeCell(Mergeds[i]).Block.Bottom]) Then
         Result := True;
    Inc(i);
  end;
end;
 
function TStringGrid.GetMergeColRowCell(acol,arow : integer) : TMergeCell;
var
 i : integer;
 found : Boolean;
begin
  result := nil;
  found := False;
  i := 0;
  while (i <= Pred(Mergeds.Count)) and not(found) do
  begin
    if ( acol in [TMergeCell(Mergeds[i]).Block.Left..TMergeCell(Mergeds[i]).Block.Right])  And
       ( arow in [TMergeCell(Mergeds[i]).Block.Top..TMergeCell(Mergeds[i]).Block.Bottom]) Then
    begin
      result := TMergeCell(Mergeds[i]);
      found := True;
    end;
    Inc(i);
  end;
end;
 
function TStringGrid.GetMergeCell(Index : integer) : TMergeCell;
begin
  result := TMergeCell(Mergeds[Index]);
end;
 
Procedure TStringGrid.SetMergeCell(Index : integer;Value : TMergeCell);
begin
  Mergeds.Items[Index] := Value;
end;
 
function WriteText(ACanvas: TCanvas; // Canvas
  ARect: TRect; // Draw rect and ClippingRect
  Text: string; // Draw text
  Alignment: TAlignment; // Text alignment
  Layout: TTextLayout; // Text layout
  MultyL: Boolean; // Word break
  EndEllipsis: Boolean; // Truncate long text by ellipsis
  RightToLeftReading: Boolean;
  CalcHeight: Boolean = False): Integer;
const
  AlignFlags: array[TAlignment] of Integer =
  (DT_LEFT or DT_EXPANDTABS or DT_NOPREFIX,
    DT_RIGHT or DT_EXPANDTABS or DT_NOPREFIX,
    DT_CENTER or DT_EXPANDTABS or DT_NOPREFIX);
  RTL: array[Boolean] of Integer = (0, DT_RTLREADING);
var
  rect1: TRect;
  txth, DrawFlag: Integer;
  lpDTP: TDrawTextParams;
begin
  DrawFlag := 0;
  if (MultyL = True) then
    DrawFlag := DrawFlag or DT_WORDBREAK;
  if (EndEllipsis = True) then
    DrawFlag := DrawFlag or DT_END_ELLIPSIS;
  DrawFlag := DrawFlag or AlignFlags[Alignment];
 
  rect1.Left := 0;
  rect1.Top := 0;
  rect1.Right := 0;
  rect1.Bottom := 0;
  rect1 := ARect;
 
  lpDTP.cbSize := SizeOf(lpDTP);
  lpDTP.uiLengthDrawn := Length(Text);
  lpDTP.iLeftMargin := 1;
  lpDTP.iRightMargin := 1;
 
  if (Layout <> tlTop) {and (MultyL = True)} then
    txth := DrawTextEx(ACanvas.Handle, PChar(Text), Length(Text), rect1, DrawFlag or DT_CALCRECT, @lpDTP)
  else
    txth := 0;
  rect1 := ARect;
 
  case Layout of
    tlTop: ;
    tlBottom: rect1.top := rect1.Bottom - txth;
    tlCenter: rect1.top := rect1.top + ((rect1.Bottom - rect1.top) div 2) - (txth  div 2);
  end;
 
  if CalcHeight then
    DrawFlag := DrawFlag or DT_CALCRECT;
  Result := DrawTextEx(ACanvas.Handle, PChar(Text), Length(Text), rect1,   DrawFlag, @lpDTP);
end;
 
procedure TStringGrid.DrawCellButton(Rect: TRect; Text: String; Style: TFontStyles; State: TGridDrawState; Alignment: TAlignment);
Var
  Shift : Integer;
  OldBrush : TBrush;
begin
  OldBrush :=  Canvas.Brush ;
  Canvas.Brush.Style := bsSolid;//bsClear;
  Canvas.Font.Style:=Style;
  Canvas.FillRect(rect);
 
  Shift:=-2 + ORD(gdFixed In State);
  InflateRect(Rect,Shift,0);
  Canvas.FillRect(Rect);
  WriteText(Canvas,Rect,Text,Alignment,tlCenter,false,false,false);
  InflateRect(Rect,(-1)*Shift,0);
 
  IF NOT (gdFixed in State) Then
  Begin
    InflateRect(Rect, 1, 1);
    FrameRect(Canvas.Handle, Rect, GetStockObject(LTGRAY_BRUSH));
    Rect.Top:=Rect.Top - 1;
    InflateRect(Rect, -2, -2);
  End
  else
  begin
    InflateRect(Rect, 1, 1);
    FrameRect(Canvas.Handle, Rect, GetStockObject(BLACK_BRUSH));
    //Rect.Top:=Rect.Top - 1;
    InflateRect(Rect, -1, -1);
    Frame3D(Canvas,rect,clWhite,clBtnShadow,1);
  end;
  Canvas.Brush :=  OldBrush ;
end;
 
procedure TStringGrid.DrawRowButton(Rect: TRect; Text: String; Style: TFontStyles; Alignment: TAlignment);
begin
  DrawCellButton(Rect,Text,Style,[],Alignment);
end;
 
procedure TStringGrid.DrawMergeCells(ACol, ARow: Longint; ARect: TRect;AState: TGridDrawState);
var
  OldRect : Trect;
  Coldeb ,RowDeb
  ,ColFin,RowFin : Integer;
  offsetRow,offsetCol : Integer;
  Data : TMergeCell;
  oldColor  : TColor;
begin
  Data := GetMergeColRowCell(aCol,ARow);
  OldRect := aRect;
  Coldeb := max(Data.Block.Left,0);
  RowDeb := max(Data.Block.Top,0);
  ColFin := min(Data.Block.Right ,ColCount);
  RowFin := Min(Data.Block.Bottom,RowCount);
 
  If   (ARow in [RowDeb..RowFin])
  and  (aCol in [Coldeb..ColFin]) Then
  begin
    Canvas.FillRect(aRect);
    offsetRow   := TopRow-FixedRows;
    offsetCol   := LeftCol-FixedCols;
   //les colones
    if FixedCols > 0 Then
      if data.Block.Left >= FixedCols Then
      begin
        ColDeb := max(data.Block.Left,LeftCol);//(+offsetCol,-FixedCols)
        ColFin := min(data.Block.Right,VisibleColCount+1+offsetCol);
        if ColFin < 0 Then
        begin
           ColFin := 0;
           ColDeb :=0;
        end;
      end;
   //les lignes
    if FixedRows > 0 Then
      if data.Block.Top >= FixedRows Then
      begin
        RowDeb := max(data.Block.Top,TopRow);
        RowFin := min(data.Block.Bottom,VisibleRowCount+1+offsetRow);
        if RowFin < 0 Then
        begin
           RowFin := 0;
           RowDeb :=0;
        end;
      end;
 
    if (ARow = RowFin) and (aCol = ColFin) Then
    begin
      aRect  := CellRect(ColDeb,RowDeb);
      aRect.Right  := CellRect(ColFin,RowFin).Right;
      aRect.Bottom := CellRect(ColFin,RowFin).Bottom;
 
      if ((VisibleColCount < colFin) or (VisibleRowCount < RowFin)) Then
      begin
        if (Canvas.TextWidth(TMergeCell(GetMergeColRowCell(ACol, ARow)).Caption) > (aRect.Right-aRect.Left)) Then
        begin
          aRect.Right  := CellRect(ColFin,RowFin).Right;
          aRect.Bottom := CellRect(ColFin,RowFin).Bottom;
          aRect := OldRect;
        end;
      end;
      oldColor := Canvas.Brush.Color;
      Canvas.Brush.Color :=  Data.Color;
      DrawRowButton(aRect, TMergeCell(GetMergeColRowCell(ACol, ARow)).Caption,canvas.Font.Style,taCenter   );
      Canvas.Brush.Color :=  oldColor;
    end
    else
    begin
      oldColor := Canvas.Brush.Color;
      if (gdFixed in AState) Then
         Canvas.Brush.Color := clBtnFace;
      DrawCellButton(ARect,Cells[ACol, ARow],canvas.Font.Style,AState,taCenter);
      Canvas.Brush.Color := oldColor ;
    end;
  end;
end;
 
procedure TStringGrid.DrawCell(ACol, ARow: Longint; ARect: TRect;AState: TGridDrawState);
var
  oldColor : TColor;
begin
  if not(IsMergeCell[aCol,ARow]) Then
  begin
    oldColor := Canvas.Brush.Color;
    if (gdFixed in AState) Then
       Canvas.Brush.Color := clBtnFace;
    DrawCellButton(ARect,Cells[ACol, ARow],canvas.Font.Style,AState,taCenter);
    Canvas.Brush.Color := oldColor ;
  end
  else
    DrawMergeCells(ACol, ARow,ARect,AState);
end;

et enfin l'utilisation

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
 
procedure TForm1.FormCreate(Sender: TObject);
begin
  StrGrid.ColWidths[0]:= 54;
  StrGrid.Cells[2,1]  := 'C';
  StrGrid.Cells[3,1]  := 'RP';
  StrGrid.Cells[4,1]  := 'RU';
  StrGrid.Cells[5,0]  := 'jeu 1';
  StrGrid.Cells[6,0]  := 'ven 2';
  StrGrid.Cells[7,0]  := 'sam 3';
  StrGrid.Cells[8,0]  := 'dim 4';
  StrGrid.Cells[9,0] := 'lun 5';
  StrGrid.Cells[10,0] := 'mar 6';
  StrGrid.Cells[11,0] := 'mer 7';
  StrGrid.AddMergeCells(0,0,1,1,'EQUIPE',clInfoBk);
  StrGrid.AddMergeCells(2,0,4,0,'Compteurs',clMaroon);
  StrGrid.AddMergeCells(0,2,1,5,'Vac1',clYellow);
  StrGrid.AddMergeCells(0,6,1,10,'Vac2',clRed);
  StrGrid.AddMergeCells(3,6,5,10,'TEST',clBlue);
end;

@+ Phil

Je pense que le code peut etre mis dans les sources
[Ps] je ne test pas les chevauchement possible entre les bloc de regroupement
[PS2] tu peut utiliser les éléments fixe de la stringgrid

**anapurna** · 20/02/2009, 19h04

Envoyé par CharleLéo

salut anapurna,

Quel boulot tu as tombé!!!

J'arrive à la même chose avec mon code, cepandant je pense que le tiens est plus optimisé. J'ai jeté un coup d'oeil vite fait sur les sources, je n'ai pas tout compris. Je vais m'y pencher dessus et m'en inspirer.

Petite remarque, à l'execution de ton code, il y un affichage intempestif des lignes des grilles.????

A+

a remplacer dans le code

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
 
Constructor  TStringGrid.Create;
begin
   inherited;
   DoubleBuffered := True;
  Mergeds := TList.Create;
end;
 
procedure TStringGrid.DrawCell(ACol, ARow: Longint; ARect: TRect;AState: TGridDrawState);
var
  oldColor : TColor;
begin
  Canvas.Lock;
  if not(IsMergeCell[aCol,ARow]) Then
  begin
    oldColor := Canvas.Brush.Color;
    if (gdFixed in AState) Then
       Canvas.Brush.Color := clBtnFace;
    DrawCellButton(ARect,Cells[ACol, ARow],canvas.Font.Style,AState,taCenter);
    Canvas.Brush.Color := oldColor ;
  end
  else
    DrawMergeCells(ACol, ARow,ARect,AState);
  Canvas.Unlock;  
end;

@+ Phil

[PS]Dis moi si tu as d'autre soucis ou d'autre amélioration

**CharleLéo** · 21/02/2009, 10h19

Salut anapurna,

Sans vouloir t'offenser, je suis resté sur mon idée à savoir :
redessiner la premiére colonne lors d'un scroll (utilisation de TopRow dans évènement OnTopLeftChange.

Voilà ce que je viens de finir d'écrire, et qui fonctionne bien :

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
unit Essai;
 
interface
 
uses
{ Composant TXStringGrid :
Authors:  Michael Dürig (md)
http://www.vclcomponents.com/Delphi/Grids/XStringrid-info.html}
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  XStringGrid, Grids,extctrls, StdCtrls;
 
type
  TForm1 = class(TForm)
     Planning: TXStringGrid; //Authors:  Michael Dürig (md)
     ComboCellEditor1: TComboCellEditor;  //Authors:  Michael Dürig (md)
     procedure PlanningDrawCell(Sender: TObject; ACol, ARow: Integer;
     Rect: TRect; State: TGridDrawState);
     procedure ScrollGrille(Grid:TStringGrid);
     procedure PlanningTopLeftChanged(Sender: TObject);
     procedure EffacerFirstCol(Sender: TObject);
     procedure FormCreate(Sender: TObject);
private
    { Déclarations privées }
public
{ Déclarations publiques }
  Scroll,NbreLigne,FirstLigne,NbreRect:Integer;
end;
 
var
  Form1: TForm1;
  Madate:tDatetime;
 
implementation
 
uses MergedForumDevelopper;
 
{$R *.DFM}
 
procedure TForm1.PlanningTopLeftChanged(Sender: TObject);
begin
  Scroll:=(Sender as TStringGrid).topRow-2;
  ScrollGrille(planning);
end;
 
procedure TForm1.ScrollGrille(Grid:TStringGrid);
var
  rect,Rect1 : trect;
  OldBrushColor:Tcolor;
  OldPenColor:Tcolor;
  OldFontSize:Integer;
  OldFontName:String;
  NumRect,ValScroll:integer;
begin
  //Initialisations diverses
  Rect := Bounds(0,0,0,0);
  OldBrushColor:=Grid.Canvas.Brush.color;
  OldPenColor:=Grid.Canvas.pen.color;
  OldFontName:=Grid.Canvas.Font.name;
  OldFontSize:=Grid.Canvas.font.Size;
  EffacerFirstCol(self);
  for NumRect:=0 to NbreRect-1 do
  begin
  // Premier rectangle pas de scroll	   
    if NumRect=0 then
      ValScroll:=0
    else
      ValScroll:=Scroll;
   // si Premiere ligne du rectangle appartient au titre de la colonne 0
    if Grid.topRow>NbreLigne*Numrect+2 then
      Rect1.Top := 2*Grid.defaultRowHeight+2-   
      Grid.defaultRowHeight+Grid.RowHeights[0]-
      Grid.defaultRowHeight+grid.RowHeights[1]
    else
      Rect1.Top := Grid.CellRect(0,Grid.TopRow+NbreLigne*NumRect-
       ValScroll).top;
   //
   Rect1.Left := 0;
   Rect1.Right := Grid.CellRect(0,(NumRect+1)*NbreLigne+1).Right;
   Rect1.Bottom := Grid.CellRect(0,(NumRect+1)*NbreLigne+1).Bottom;
   //
   Grid.canvas.FillRect(Rect1);
   Grid.canvas.brush.Color:=$0080FFFF;
   Canvas.Pen.Color := clSilver;
   Grid.canvas.FillRect(Rect1);
   if (Rect1.bottom-Grid.defaultRowHeight)<0 then
    begin
     // Le bloc qui suit pour imiter le "look" par défaut
       if Grid.GridLineWidth = 1 then
         begin
	Canvas.brush.Color:=clwindow;
	Grid.canvas.Pen.Color := clblack;
	Grid.canvas.Pen.Width := 1;
	Grid.canvas.Rectangle(Rect1.Left-1,Rect1.Top-1,Rect1.Right,
             Rect1.Bottom+1);
         end;
    end;
    Frame3D(Grid.Canvas, Rect1, clBtnHighlight, clBtnShadow, 1);
    InflateRect(Rect1,-2,-2);
    Grid.Canvas.font.Color:=clblack;
    DrawText(Grid.Canvas.Handle, PChar(Grid.Cells[0,(NumRect*NbreLigne+ 
    2)]),-1, Rect1 ,DT_CENTER or DT_NOPREFIX or DT_VCENTER or 
    DT_SINGLELINE  );
  end;
  Planning.Canvas.Pen.Color:=clBlack;
  //
  Rect:=Planning.CellRect(0,Planning.topRow);
  Planning.Canvas.MoveTo(rect.left,rect.top-1);
  Planning.Canvas.LineTo(Planning.FixedCols* 
  (Rect.left+Planning.defaultColWidth+1),(rect.top-1));
  Grid.Canvas.Brush.color:=OldBrushColor;
  Grid.Canvas.pen.color:=OldpenColor;
  Grid.Canvas.Font.name:=OldFontName;
  Grid.Canvas.font.Size:=OldFontSize;
  //	
end;
 
procedure TForm1.PlanningDrawCell(Sender: TObject; ACol, ARow: Integer;
  Rect: TRect; State: TGridDrawState);
var
	Grid:TXStringGrid;
	Cell3D:Boolean;
	OldFontSize:Integer;
	OldFontName:String;
	OldBrushColor:Tcolor;
begin
	Grid:=(sender as TXstringGrid);
	OldBrushColor:=grid.Canvas.Brush.color;
	OldFontSize:=Grid.canvas.font.size;
	OldFontName:= Grid.canvas.font.name;
	begin
		if (
		 (not MergedCells(Grid,Acol,Arow,0,0,0,1,State,clBtnFace,DT_CENTER or DT_NOPREFIX or DT_VCENTER or DT_SINGLELINE,Cell3D=True)) and   // EQUIPE
			  (not MergedCells(Grid,Acol,Arow,1,0,2,1,State,clBtnFace,DT_CENTER or DT_NOPREFIX or DT_VCENTER or DT_SINGLELINE,Cell3D=True)) and   // Agent
			  (not mergedCells(Grid,Acol,Arow,3,0,5,0,State,clBtnFace,DT_CENTER or DT_NOPREFIX or DT_VCENTER or DT_SINGLELINE,Cell3D=True)) and  // compteurs
			  (not mergedCells(Grid,Acol,Arow,3,1,3,1,State,clBtnFace,DT_CENTER or DT_NOPREFIX or DT_VCENTER or DT_SINGLELINE,Cell3D=True)) and
				(not mergedCells(Grid,Acol,Arow,4,1,4,1,State,clBtnFace,DT_CENTER or DT_NOPREFIX or DT_VCENTER or DT_SINGLELINE,Cell3D=True)) and
			  (not mergedCells(Grid,Acol,Arow,5,1,5,1,State,clBtnFace,DT_CENTER or DT_NOPREFIX or DT_VCENTER or DT_SINGLELINE,Cell3D=True))
     ) then
			begin
				If (acol<Grid.Fixedcols) then
					begin
						Grid.Canvas.brush.Color:=clwindow;
						Grid.Canvas.Pen.Color := clSilver;
						Grid.Canvas.Pen.Width := 1;
						Grid.Canvas.Rectangle(Rect.Left-1,Rect.Top-1,Rect.Right+1,
						Rect.Bottom+1);
						DrawText(Grid.canvas.Handle, PChar(grid.Cells[ACol,ARow]),-1,
						Rect ,DT_CENTER or DT_NOPREFIX or DT_VCENTER or
						DT_SINGLELINE );
					end
				else
					if (arow in [0..1]) and (acol in [6..Grid.colCount-1]) then
						drawtext(Grid.canvas.Handle,pchar(grid.cells[aCol,aRow]),-1,rect,DT_CENTER or DT_NOPREFIX or DT_VCENTER or DT_SINGLELINE )
					else
						// Formatage donnée saisie dans la grille
						if (arow in [2..Grid.RowCount-1]) and (acol in [6..Grid.colCount-1]) then
						begin
							Grid.canvas.font.Name:='Microsoft Sans Serif';
							grid.canvas.font.size:=8;
							Grid.Canvas.font.Color:=clred;
							drawtext(Grid.canvas.Handle,pchar(grid.cells[aCol,aRow]),-1,rect,DT_CENTER or DT_WORDBREAK);
						end;
			end;
	end;
	grid.Canvas.Brush.Color:=OldBrushColor;
	Grid.canvas.font.name:=OldFontName;
	Grid.canvas.font.size:=OldFontSize;
	ScrollGrille(Planning);
end;
 
procedure TForm1.EffacerFirstCol(Sender: TObject);
var
x:integer;
rect:trect;
begin
	for x:=2 to planning.RowCount-1 do
		begin
			Rect.Left :=Planning.CellRect(0,x).Left;
			Rect.Top := Planning.CellRect(0,x).top;
			Rect.Right := Planning.CellRect(0,x).Right;
			Rect.Bottom := Planning.CellRect(0,x).Bottom;
			Planning.canvas.FillRect(Rect);
			if Planning.GridLineWidth = 1 then
				begin
					Planning.Canvas.brush.Color:=ClWindow;
					Planning.canvas.Pen.Color := ClSilver;
					Planning.canvas.Pen.Width := 1;
					Planning.canvas.Rectangle(Rect.Left-1,Rect.Top-1,Rect.Right,Rect.Bottom+1);
				end;
		end;
end;
 
procedure TForm1.FormCreate(Sender: TObject);
var
	x,y:integer;
begin
	MaDate:=now;
	planning.RowHeights[0]:=15;
	planning.RowHeights[1]:=20;
	Planning.Cells[0,0]:='EQUIPE';
	Planning.Cells[1,0]:='AGENTS' ;
	Planning.Cells[3,0]:='Compteurs';
	Planning.Cells[3,1]:='C';
	Planning.Cells[4,1]:='RP';
	Planning.Cells[5,1]:='RQ';
	planning.cells[0,2]:='VAC 1';
	planning.cells[0,6]:='VAC 2';
	planning.cells[0,10]:='VAC 3';
	planning.cells[0,14]:='VAC 4';
	for x:=0 to 30 do
		if (x mod 2)=0 then
			planning.cells[2,x+2]:='TOTO '+inttostr(x);
	for x:=0 to planning.colCount-1 do
		begin
			planning.Cells[x+Planning.FixedCols,0]:=UpperCase((FormatDateTime('ddd',maDate+x)));
			planning.Cells[x+Planning.FixedCols,1]:=UpperCase(FormatDateTime('dd',maDate+x));
		end;
		// remplacant / Titulaires
	for y:=1 to 25 do
		if (y mod 2)=0 then
			planning.cells[1,y]:='T'
		else
			planning.cells[1,y]:='R' ;
	// hauteur des cellule fusionnées première colonne
	NbreLigne:=4;
	// nombre de boite à afficher 
	NbreRect:=3;// 
	Scroll:=0;// init du scroll
end;
 
 
end.

le seul pb que je dois résoudre maintenant, c'est lors du scroll, pouvoir scroller de x lignes. je cherche....

Que penses tu de mon code?

Ps : j'utilise le TXStringGrid Michael Dürig (md) voir adresse dans code, qui permet de redimensionner les colonnes et de mettre un combobox dans chaque cellule.

Je n'arrive toujours pas à copier mon code correctement dans la balise, je suis obligé de passer un bon moment à le remettre en forme pour qu'il soit lisible, si quelqu'un connait la solution, je suis preneur.

A+

Houps, j'ai oublié le code trouvé sur developpez.com que j'ai un peu modifié .

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
unit MergedForumDevelopper;
 
interface
 
uses  Windows, Messages, SysUtils, Classes, Graphics, Controls,
	Grids, StdCtrls,extctrls,XStringGrid;
 
	function MergedCells(Planning:TXStringGrid; ColEnCours,RowEnCours,ColDeb,RowDeb,ColFin,RowFin:Integer;
	ACurrentState: TGridDrawState;Couleur:Tcolor;Alignement:Integer;Cell3D:Boolean):Boolean;
 
implementation
 
function MergedCells(Planning:TXStringGrid; ColEnCours,RowEnCours,ColDeb,RowDeb,ColFin,RowFin:Integer; ACurrentState: TGridDrawState;Couleur:Tcolor;
Alignement:Integer;Cell3D:Boolean):Boolean;
var
  x1,y1,x2,y2:Integer;
	Rect:TRect;
	OldFontName:String;
	OldFontSize:Integer;
begin
	with Planning, Canvas do
	begin
		OldFontName:=Planning.Canvas.Font.name;
		OldFontSize:=Planning.Canvas.Font.Size;
         x1 := ColDeb;
         y1 := RowDeb;
         x2 := ColFin;
         y2 := RowFin;
         result := false;
         //On vérifie que la zone fusionnée est valide
         if x1 < 0 then x1 := 0;
         if x2 > ColCount-1 then x2 := ColCount-1;
         if y1 < 0 then y1 := 0;
         if y2 > RowCount-1 then y2 := RowCount-1;
         if (x1 > x2) or (y1 > y2) then
            begin
                 result := false;
                 exit;
            end;
         //Si la cellule courante est la dernière de la zone de fusion, on dessine dans la fusion le texte de la cellule en haut à gauche
         if ((ColEnCours=ColFin) and (RowEnCours=RowFin)) then
            begin
                 Rect.Left := CellRect(ColDeb,RowDeb).Left;
                 Rect.Top := CellRect(ColDeb,RowDeb).Top;
		         Rect.Right := CellRect(ColFin,RowFin).Right;
		         Rect.Bottom := CellRect(ColFin,RowFin).Bottom;
		         brush.Color:=Couleur;
		         FillRect(Rect);
		         // Le bloc qui suit pour imiter le "look" par défaut
	             if GridLineWidth = 1 then
                    begin
			             Pen.Color := ClBlack;
                         Pen.Width := 1;
                         Canvas.Rectangle(Rect.Left-1,Rect.Top-1,Rect.Right+1,Rect.Bottom)
                    end;
                 Frame3D(Canvas, Rect, clBtnHighlight, clBtnShadow, 1);
								 InflateRect(Rect,-1,-1);
								 canvas.Font.name:='Microsoft Sans Serif';
								 Canvas.Font.size:=10;
	             DrawText(Handle, PChar(Cells[ColDeb,RowDeb]),-1, Rect ,Alignement);
            end;
         //Si la cellule courante est dans la zone de fusion, on dit qu'on la dessiné (même si ce n'est pas vrai :) )
         if ((ColEnCours>=ColDeb) and (RowEnCours>=RowDeb) and (ColEnCours<=ColFin) and (RowEnCours<=RowFin)) then
            begin
                 result := True;
                 //DrawText(Handle, PChar(Cells[ColDeb,RowDeb]),-1, Rect ,Alignement);
                    end;
		Planning.Canvas.Font.name:=OldFontName;
		Canvas.Font.Size:=OldFontSize;
		end;
 
end;
 
end.

**ero-sennin** · 21/02/2009, 13h01

Salut,

Pour l'histoire du code, heu, si dans ton IDE c'est présenté correctement, suffit de copier puis de coller, c'est tout

.

Je n'ai jamais rencontré de problème ... Faut pas chercher à le remettre en forme sur le forum, car là, oui, tu risques d'avoir une mauvaise indentation.

A+

Fusionner des cellules dans stringgrid

Composants VCL Delphi

Discussions similaires

Partager

Partager