Composant grille avec nouvelles propriétés
Soyez le premier à donner votre avis sur cette source.
Vue 5 136 fois - Téléchargée 756 fois
Description
- Propriété About = Auteur-Concepteur.
- Propriété Aide = Aide descriptif sur les Propriétés.
- Propriété AlignText : Formatte un texte dans les Cellules
- Propriété Automatic : Ajuste automatiquement la Largeur et Hauteur de la Grille.
- Propriété FormatNumeric : Formatage à droite des cellules contenant des nombres.
- Propriété CellColor: CellCor : Couleur pour la Cellule choisie. (ou ligne ou Colonne).
- Fonction Publiée : ChangeCellColor(Acol,ARow:Integer) - Couleur de Cellule.
- Propriété Picture : Image BitMap sélectionnée pour la fonction CellBitMap.
- Utilisation de la Fonction Publiée : CellBitMap(ACol,ARow:Integer).
- Propriété Aide = Aide descriptif sur les Propriétés.
- Propriété AlignText : Formatte un texte dans les Cellules
- Propriété Automatic : Ajuste automatiquement la Largeur et Hauteur de la Grille.
- Propriété FormatNumeric : Formatage à droite des cellules contenant des nombres.
- Propriété CellColor: CellCor : Couleur pour la Cellule choisie. (ou ligne ou Colonne).
- Fonction Publiée : ChangeCellColor(Acol,ARow:Integer) - Couleur de Cellule.
- Propriété Picture : Image BitMap sélectionnée pour la fonction CellBitMap.
- Utilisation de la Fonction Publiée : CellBitMap(ACol,ARow:Integer).
Source / Exemple :
unit TGrille; // Composant Visuel Grille Hérité TStringGrid @ Guy Bidi 2008
interface
uses Windows,SysUtils,Classes,Controls,Grids,Types,Graphics,Forms,StdCtrls,
Dialogs,ShellApi;
Const Mess=' Propriété About : Auteur : © Guy Bidi - paounet@free.fr'+Chr(13)+Chr(13)+
' 1 - La Propriété Aide à True affiche l''Aide actuelle.'+Chr(13)+Chr(13)+
' 2 - La Propriété AlignText :'+Chr(13)+Chr(13)+
' Left : Aligne à Gauche le texte des Cellules.'+Chr(13)+
' Center : Aligne au Centre le texte des Cellules.'+Chr(13)+
' Right : Aligne à Droite le texte des Cellules.'+Chr(13)+Chr(13)+
' 3 - La Propriété Automatic : Ajuste la Largeur et Hauteur de la Grille (True ).'+Chr(13)+Chr(13)+
' 4 - La Propriété FormatNumeric : '+Chr(13)+Chr(13)+
' En utilisant les symbôles de formatage tels que #, 0, . les cellules contenant des'+Chr(13)+
' nombres seront formatés à droite comme la fonction FormatFloat (''0.##'',Valeur).'+Chr(13)+Chr(13)+
' 5 - La Propriété CellColor: CellCor : Couleur pour la Cellule choisie.'+Chr(13)+Chr(13)+
' IndexCol : Index de Colonne / IndexRow : Index de Ligne.'+Chr(13)+
' Si IndexRow/IndexCol est vide alors toute la colonne/Ligne sera affichée '+Chr(13)+
' avec la couleur issue de CellColor.'+Chr(13)+Chr(13)+
' 6- Utilisation de la Fonction Publiée : ChangeCellColor(Acol,ARow:Integer)'+Chr(13)+Chr(13)+
' - Couleur de Cellule : CellColor.Color '+Chr(13)+Chr(13)+
' 7 - La Propriété Picture : Image BitMap sélectionnée pour la fonction CellBitMap'+Chr(13)+Chr(13)+
' 8- Utilisation de la Fonction Publique : CellBitMap(ACol,ARow:Integer)'+Chr(13)+Chr(13)+
' Grille1.CellBitMap(-1,-1) Toute la Grille est dessinée'+Chr(13)+
' Grille1.CellBitMap(2,3); La Cellule(2,3) est dessinée'+Chr(13)+
' Grille1.CellBitMap(-1,2); Toute la Ligne N° 2 est dessinée'+Chr(13)+
' Grille1.CellBitMap(2,-1); Toute la Colonne N° 2 est dessinée';
type
TCellColor = class(TPersistent) // Propriétés rajoutées à Grille
private { Déclarations privées } // Variables Utilisées
FColor:TColor;FCol:String;FRow:String; // Couleur, Colonne, Ligne
Procedure SetCol(Value:String);
Procedure SetRow(Value:String);
protected { Déclarations protégées }
public { Déclarations publiques }
Constructor Create(Owner:Tcomponent);
published { Déclarations publiées }
Property Color:TColor Read FColor Write FColor;
Property IndexCol:String Read FCol Write SetCol;
Property IndexRow:String Read FRow Write SEtRow;
end;
type
TAbout=String; // Propriété About rajoutée
TAide=Boolean; // Propriété Aide sur le Composant
TAlignText=(Left,Center,Right); // Propriété Alignement du Texte
TAuto=Boolean; // Ajuste la Grille Automatiquement
TFormat=String; // Propriété Format pour Numérique
Grille = class(TStringGrid)
private { Déclarations privées } // Variables Utilisées
FAbout:TAbout;FAide:TAide;FAlignText:TAlignText;Fauto:TAuto;FFormat:TFormat;
FCellColor:TCellColor;FormAide:TForm;Memo:TMemo;FBitMap:TBitMap;
protected { Déclarations protégées }
procedure DrawCell(ACol:Longint;ARow:Longint;Rectangle:TRect;State:TGridDrawState); override;
procedure MemoDblClick(Sender:TObject);
procedure SetBitMap(Value:TBitMap);
public { Déclarations publiques }
Constructor Create(Owner:Tcomponent);override;
destructor Destroy;Override;
published { Déclarations publiées }
Property About:TAbout read FAbout;
Property Aide:TAide read FAide Write FAide;
Property AlignText:TAlignText read FAlignText Write FAlignText;
Property Automatic:TAuto read FAuto Write FAuto;
Property FormatNumeric:TFormat Read FFormat Write FFormat;
Property CellColor:TCellColor Read FCellColor Write FCellColor;
Property CellPicture:TBitMap Read FBitMap Write SetBitMap;
Procedure ChangeColorCell(ACol,ARow:Integer);
Procedure CellBitMap(ACol,ARow:Integer);
end;
procedure Register;
implementation
Procedure Grille.MemoDblClick(Sender:TObject);
Begin
FormAide.ModalResult:=mrOk;
End;
Constructor TCellColor.Create(Owner:TComponent);
Begin
// Rien Ici
End;
procedure Grille.SetBitMap(Value:TBitMap);
begin
If Value<>Nil Then FBitMap.Assign(Value);
end;
Constructor Grille.Create(Owner:TComponent);
Begin
Inherited Create(Owner);FixedCols:=0;FixedRows:=0;FAbout:='© Guy Bidi - 2008';
Font.Name:= 'Comic Sans MS';ScrollBars:=ssNone;FAlignText:=Center;
FAuto:=True;FAide:=False;Font.Style:=[fsBold];FFormat:='';Color:=clMoneyGreen;
If Owner Is TForm Then With TForm(Owner)Do Position:=poScreenCenter;
FormAide:=TForm.CreateNew(Application);With FormAide Do Begin Left:=0;Top:=0;
AutoSize:=True;BorderIcons:=[];BorderStyle:=bsDialog;ClientHeight:=577;
Caption:='Les Nouvelles Propriétés du Composant Grille © Guy Bidi - 2008';
ClientWidth:=561;Color:=clBtnFace;Font.Charset:=DEFAULT_CHARSET;Font.Style:=[];
Font.Color:=clWindowText;Font.Height:=-13;Font.Name:='Century Gothic';
OldCreateOrder:=False;Position:=poScreenCenter;PixelsPerInch:=120;End;
Memo:=TMemo.Create(Owner);With Memo Do Begin Parent:=FormAide;Left:=0;Top:=0;
Width:=567;Height:=608;Hint:='Double-Cliquer pour sortir';Color:=clSkyBlue;
Font.Charset:=DEFAULT_CHARSET;Font.Color:=clBlack;Font.Height:=-13;
Font.Name:='Century Gothic';Font.Style:=[fsBold];ParentFont:=False;
ParentShowHint:=False;ShowHint:=True;Lines.Text:=Mess;
WantReturns:=True;OnDblClick:=MemoDblClick;End;
FCellColor:=TCellColor.Create(Self);With FCellColor Do Begin
FColor:=Color;FCol:='';FRow:='';End;
FBitMap:=TBitMap.Create;
End;
Procedure TCellColor.SetCol(Value:String);
Begin
If Not(Ord(Copy(Value,1,1))) In [49..59] Then Value:='';FCol:=Value;
End;
Procedure TCellColor.SetRow(Value:String);
Begin
If Not(Ord(Copy(Value,1,1))) In [49..59] Then Value:='';FRow:=Value;
End;
Procedure Grille.DrawCell(ACol,ARow:Integer;Rectangle:TRect;State:TGridDrawState);
Var Valeur:Real;Code,i,j:Integer;
Begin // Surchage OnDrawCell de la Grille
Val(Trim(Cells[ACol,ARow]),Valeur,Code);
If (FFormat<>'') And (Code=0) And (Trim(Cells[ACol,ARow])<>'') Then
DrawText(Canvas.Handle,PWideChar(FormatFloat(FFormat,Valeur)),
-1,Rectangle,DT_RIGHT or DT_NOPREFIX or DT_VCENTER or DT_SINGLELINE)
Else
If FAlignText=Center then DrawText(Canvas.Handle,PWideChar(Cells[ACol,ARow]),
-1,Rectangle,DT_CENTER or DT_NOPREFIX or DT_VCENTER or DT_SINGLELINE)
Else If FAlignText=Right then DrawText(Canvas.Handle,PWideChar(Cells[ACol,ARow]),
-1,Rectangle,DT_RIGHT or DT_NOPREFIX or DT_VCENTER or DT_SINGLELINE)
Else DrawText(Canvas.Handle,PWideChar(Cells[ACol,ARow]),
-1,Rectangle,DT_LEFT or DT_NOPREFIX or DT_VCENTER or DT_SINGLELINE);
If FAuto=True then Begin
Width:=ColCount*DefaultColWidth+(ColCount+1)*GridLineWidth;
Height:=RowCount*DefaultRowHeight+(RowCount+1)*GridLineWidth;End;
If FAide then Begin FAide:=False;FormAide.ShowModal;End;
If (FCellColor.FCol='') And (FCellColor.FRow='') Then Exit;
If (FCellColor.FCol<>'') And (FCellColor.FRow<>'') And
(StrToInt(FCellColor.FRow)<RowCount) And
(StrToInt(FCellColor.FCol)<ColCount) Then Begin
ChangeColorCell(StrToInt(FCellColor.Fcol),StrToInt(FCellColor.FRow));Exit;End;
If FCellColor.FCol='' Then Begin
If StrToInt(FCellColor.FRow)<RowCount Then Begin
For i := 0 to ColCount - 1 do For j := 0 to RowCount-1 do Begin
ChangeColorCell(i,StrToInt(FCellColor.FRow));End;Exit;End
Else Begin MessageDlg('Valeur de Ligne trop grande',mtInformation,[mbOk],0,mbOk);
FCellColor.FRow:='';Exit;End;End
Else If FCellColor.FRow='' Then Begin
If StrToInt(FCellColor.FCol)<ColCount Then Begin
For i := 0 to ColCount - 1 do For j := 0 to RowCount-1 do Begin
ChangeColorCell(StrToInt(FCellColor.FCol),j);End;Exit; End
Else Begin MessageDlg('Valeur de Colonne trop grande',mtInformation,[mbOk],0,mbOk);
FCellColor.FCol:='';Exit;End;End;
FBitMap:=TBitMap.Create;FBitMap:=Nil;
End;
Procedure Grille.CellBitMap(ACol,ARow:Integer); // Procedure Publique CellBitMap
Var Rect,Rect1:TRect;
Begin
If ACol<0 Then // Pas de Colonne
If ARow<0 Then Begin // Toute la Grille est dessinée...
Rect:=BoundsRect;Rect.Right:=Rect.Right-Rect.Left;
Rect.Bottom:=Rect.Bottom-Rect.Top;Rect.Left:=0;Rect.Top:=0;End
Else // Toute une Colonne est dessinée
If ARow>RowCount-1 Then Begin MessageDlg('Valeur de Ligne trop grande',
mtInformation,[mbOk],0,mbOk);Exit;End
Else Begin // Toute une Ligne est dessinée
Rect:=CellRect(0,ARow);Rect1:=CellRect(ColCount-1,ARow);
Rect.Right:=Rect1.Right;Rect.Bottom:=Rect1.Bottom;End
Else If ARow<0 then
If ACol>ColCount-1 Then Begin MessageDlg('Valeur de Ligne erronée',
mtInformation,[mbOk],0,mbOk);Exit;End
Else Begin // Toute une Colonne est dessinée
Rect:=CellRect(ACol,0);Rect1:=CellRect(ACol,RowCount-1);
Rect.Right:=Rect1.Right;Rect.Bottom:=Rect1.Bottom;End
Else If (ACol>ColCount-1) Or (ARow>RowCount-1) Then Begin
MessageDlg('Valeur de Colonne/Ligne erronée',mtInformation,[mbOk],0,mbOk);
Exit;End Else Rect:=CellRect(ACol,ARow); // Une seule Cellule est dessinée
Canvas.StretchDraw(Rect,CellPicture); // Affiche le dessin dans Cellule(s)
End;
Procedure Grille.ChangeColorCell(ACol,ARow:Integer); // Changement de Couleur/Cellule
Var Valeur:Real;Code:Integer;Rectangle:TRect;
Begin
Canvas.Brush.Color:=FCellColor.FColor;
Rectangle:=CellRect(ACol,ARow);
Canvas.TextRect(Rectangle,Rectangle.Left,Rectangle.Top,'');
If Cells[ACol,ARow]<>'' then Begin
Val(Trim(Cells[ACol,ARow]),Valeur,Code);
If (FFormat<>'') And (Code=0) And (Trim(Cells[ACol,ARow])<>'') Then
DrawText(Canvas.Handle,PWideChar(FormatFloat(FFormat,Valeur)),
-1,Rectangle,DT_RIGHT or DT_NOPREFIX or DT_VCENTER or DT_SINGLELINE)
Else
If FAlignText=Center then DrawText(Canvas.Handle,PWideChar(Cells[ACol,ARow]),
-1,Rectangle,DT_CENTER or DT_NOPREFIX or DT_VCENTER or DT_SINGLELINE)
Else If FAlignText=Right then DrawText(Canvas.Handle,PWideChar(Cells[ACol,ARow]),
-1,Rectangle,DT_RIGHT or DT_NOPREFIX or DT_VCENTER or DT_SINGLELINE)
Else DrawText(Canvas.Handle,PWideChar(Cells[ACol,ARow]),
-1,Rectangle,DT_LEFT or DT_NOPREFIX or DT_VCENTER or DT_SINGLELINE);
End;
end;
destructor Grille.Destroy; // Destruction du Composant
begin
inherited Destroy;
end;
procedure Register; // Enregistre le Composant Grille
begin
RegisterComponents('Guy Bidi',[Grille]);
end;
end.
Test du Composant Grille = Fichier TTest.pas (Test.dproj)
unit TTest;
interface
uses Windows,Messages,SysUtils,Variants,Classes,Graphics,Controls,Forms,
Dialogs,Grids,TGrille,StdCtrls,Buttons,Types;
type
TFormGrille = class(TForm)Cellules:TSpeedButton;
CellBitMapT: TSpeedButton;
CellBitMapC: TSpeedButton;
CellBitMapCol: TSpeedButton;
CellBitMapRow: TSpeedButton;
Grille1: Grille;
procedure FormShow(Sender:TObject);
procedure CellulesClick(Sender:TObject);
procedure CellBitMapClick(Sender:TObject);
end;
var FormGrille:TFormGrille;Flag:Boolean;Ori:TColor;
implementation
{$R *.dfm}
procedure TFormGrille.CellBitMapClick(Sender:TObject);
begin
case TSpeedButton(Sender).Tag of
0:Grille1.CellBitMap(-1,-1);
1:Grille1.CellBitMap(2,3); // Cellule 2,3
2:Grille1.CellBitMap(3,-1); // Colonne N° 3
3:Grille1.CellBitMap(-1,2); // Ligne N° 2
end;
end;
procedure TFormGrille.CellulesClick(Sender:TObject);
Var i:Integer;
begin
With Grille1 Do Begin If Flag then CellColor.Color:=Color Else
CellColor.Color:=Ori;Flag:=Not(Flag);
For i:= 0 to 4 do ChangeColorCell(i,i);End;
end;
procedure TFormGrille.FormShow(Sender:TObject);
begin
Flag:=False;With Grille1 Do Begin Ori:=Grille1.CellColor.Color;
Cells[0,0]:='12345.34';Cells[1,1]:='12.55';Cells[2,2]:='0.75';
Cells[3,3]:='Guy Bidi';End;
end;
end.
Codes Sources
- Grille.dcu
- Grille.dpk
- Grille.dproj
- Grille.dproj.local
- Grille.identcache
- Grille.res
- Help.dproj.local
- Help.ico
- Help.identcache
- Test.dcu
- Test.dfm
- Test.dpr
- Test.dproj
- Test.dproj.local
- Test.ico
- Test.identcache
- Test.res
- Tgrille.bmp
- Tgrille.dcr
- Tgrille.dcu
- TGrille.pas
- Tgrille.pas.ori
- Ttest.dcu
- Ttest.dfm
- Ttest.pas
A voir également
- Grille mbok
- Chr pascal - Meilleures réponses
- Ajout usercontrol - nouvelles propriétés non visible en mode design ✓ - Forum - VB.NET
- Création de composant : modifier une sous propriete à partir d'une autre ✓ - Forum - Delphi / Pascal
- Nouvelle propriété visible dans le IDE ✓ - Forum - VB.NET
- Création d'une nouvelle propriété ✓ - Forum - Visual Basic 6
- Créer une nouvelle propriété avec valeur par défaut ✓ - Forum - C# / .NET
Commentaires
- Messages postés
-
37
- Date d'inscription
- mercredi 14 avril 2004
- Statut
- Membre
- Dernière intervention
- 6 avril 2016
1Voir --> Grille = class(TStringGrid)etc...
Pourquoi Grille et pas TGrille ?
- Messages postés
-
37
- Date d'inscription
- mercredi 14 avril 2004
- Statut
- Membre
- Dernière intervention
- 6 avril 2016
1If Not(Ord(Copy(Value,1,1))) In [49..59] Then Value:='';FCol:=Value; peut être remplacé par :
If Ord(Copy(Value,1,1)) In [49..59] Then FCol:=Value Else FCol:=''; ou
If Copy(Value,1,1) In ['0'..'9'] Then FCol:=Value Else FCol:='';
------------------------------------------------------------------------
PWideChar = essayer PChar... PAnsiChar
------------------------------------------------------------------------
Pour MessageDlg remplacez le par la fonction MessageBox ou remplacer dans Uses
Dialogs par QDialogs
Je suis sur D7 pro et beaucoup d'erreurs de compilations ex
[Erreur] TGrille.pas(107): Types incompatibles
[Erreur] TGrille.pas(111): Types incompatibles
[Avertissement] TGrille.pas(118): Transtypage ambigu de String en PWideChar
[Avertissement] TGrille.pas(121): Transtypage ambigu de String en PWideChar
[Avertissement] TGrille.pas(123): Transtypage ambigu de String en PWideChar
[Avertissement] TGrille.pas(125): Transtypage ambigu de String en PWideChar
[Erreur] TGrille.pas(140): Trop de paramètres originaux
[Erreur] TGrille.pas(146): Trop de paramètres originaux
[Erreur] TGrille.pas(159): Trop de paramètres originaux
[Erreur] TGrille.pas(165): Trop de paramètres originaux
[Erreur] TGrille.pas(170): Trop de paramètres originaux
[Avertissement] TGrille.pas(183): Transtypage ambigu de String en PWideChar
[Avertissement] TGrille.pas(186): Transtypage ambigu de String en PWideChar
[Avertissement] TGrille.pas(188): Transtypage ambigu de String en PWideChar
[Avertissement] TGrille.pas(190): Transtypage ambigu de String en PWideChar
[Erreur fatale] Ttest.pas(4): Impossible de compiler l'unité utilisée 'TGrille.pas'
Genre
Procedure TCellColor.SetCol(Value:String);
Begin
If Not(Ord(Copy(Value,1,1))) In [49..59] Then Value:='';FCol:=Value;
End;
Ord demande un numerique...
Vous n'êtes pas encore membre ?
inscrivez-vous, c'est gratuit et ça prend moins d'une minute !
Les membres obtiennent plus de réponses que les utilisateurs anonymes.
Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.
Le fait d'être membre vous permet d'avoir des options supplémentaires.