0/5 (10 avis)
Vue 5 795 fois - Téléchargée 817 fois
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.
15 févr. 2015 à 11:11
7 janv. 2009 à 13:14
Voir --> Grille = class(TStringGrid)etc...
7 janv. 2009 à 11:17
Pourquoi Grille et pas TGrille ?
6 janv. 2009 à 13:49
If 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
6 janv. 2009 à 11:44
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.