MAKE CAB + CHECKLISTBOX
f0xi
Messages postés
4205
Date d'inscription
samedi 16 octobre 2004
Statut
Modérateur
Dernière intervention
12 mars 2022
-
20 avril 2006 à 18:33
cs_Forman Messages postés 600 Date d'inscription samedi 8 juin 2002 Statut Membre Dernière intervention 6 avril 2010 - 29 juin 2006 à 19:53
cs_Forman Messages postés 600 Date d'inscription samedi 8 juin 2002 Statut Membre Dernière intervention 6 avril 2010 - 29 juin 2006 à 19:53
Cette discussion concerne un article du site. Pour la consulter dans son contexte d'origine, cliquez sur le lien ci-dessous.
https://codes-sources.commentcamarche.net/source/37164-make-cab-checklistbox
https://codes-sources.commentcamarche.net/source/37164-make-cab-checklistbox
29 juin 2006 à 19:53
type
IStrings=interface
function GetCount:Integer;
property Count:Integer read GetCount;
function GetItem(const Index:Integer):string;
procedure SetItem(const Index:Integer;const Value:string);
property Item[Index:Integer]:string read GetItem write SetItem;
end;
TStringsImplementation=class(TInterfacedObject,IStrings)
function GetCount:Integer;
function GetItem(const Index:Integer):string;
procedure SetItem(const Index:Integer;const Value:string);
destructor Destroy;override;
end;
...faire l'implémentation de l'objet TStringsImplementation...
On pourrait alors déclarer la fonction qui renvoie une liste de chaînes de la fonction suivante:
function TCheckListBox.GetChecks:IStrings;
begin
Result:=TStringsImplementation.Create;
Result.Add(...);
end;
Lorsque quelqu'un utilise la fonction ainsi:
with CheckListBox1.GetChecks do begin
ShowMessage('Il y a '+IntToStr(Count)+' items sélecionnés');
end;
la mémoire sera libérée, car il y a des appels implicites à _AddRef et _Release qui font -avec le mécanisme de comptage de référence des interfaces- qu'à l'issue de cet appel, l'objet TStringsImplementation est détruit. C'est une solution propre et élégante, mais qui nécessite toutefois d'écrire un peu plus de code (ceci dit écrire l'implémentation de TStringsImplementation ne me paraît pas très difficile...).
29 juin 2006 à 19:44
begin
List.BeginUpdate;
try
List.Add(...);
finally
List.EndUpdate;
end;
end;
"AddToList" a l'avantage d'être un nom explicite. BeginUpdate...EndUpdate permet de ne pas dégrader les performances avec des TStrings associés à des contrôles par exemple.
23 avril 2006 à 22:04
en fait je parler de rendre disponible le retour de la fonction pour l'utiliser comme control ou comme information.
pour ce que tu dis :
La création est inutile ici.
procedure SetList(List : TStrings);
begin
list.Clear
List.Add(...);
end;
attention, toute fois, si il s'agit d'une liste non visuelle, pas de probleme, par contre si il s'agit d'un composant visuel, le fait de faire des ADD vas rafraichir le compo et degradé les preformance d'ou le buffer de type TStringList pour d'abord créer la liste puis envoyer la liste a l'objet en argument.
21 avril 2006 à 22:10
Regarde ma solution de près et tu veras que le code Repeat Until n'est appelé que si le If est vrai. Le traitement ne seront donc bien effectué que sur le premier élément.
Pour ta solution
procedure SetList(List : TStrings);
var TMPLIST : TStringList;
begin
try
TMPLIST := TStringList.Create;
...
TMPLIST.Add(...);
...
List.Assign(TMPLIST);
finally
TMPLIST.Free;
end;
end;
La création est inutile ici.
procedure SetList(List : TStrings);
begin
list.Clear
List.Add(...);
end;
Pour répondre à un point au dessus aussi, tu dis que le résultat est libéré car c'est une variable locale. C'est FAUX. Seules les chaines et les tableaux dynamiques sont dans ce cas, dans tous les autres c'est à toi de le gérer.
21 avril 2006 à 11:02
Erreur que j'ai répétée et que nono a corrigée, c'est qu'un retour de ce type ne serat jamais libéré durant l'execution, soit, pas liberée en memoire.
donc si la liste pese 15Koctet et qu'on appel 100 fois la fonction, on provoque une fuite de memoire de 1500 Ko (1.5Mo)
donc il faut faire comme on vient de te le dire, passer la List dans les arguments et non dans le retour de fonction.
soit :
procedure TCheckListBox.GetSelection(OutList : TStrings);
var
i : Integer;
TPL : TStringList;
begin
try
TPL : TStringList;
For i := 0 to Items.Count - 1 do
if Checked[i] then TPL.Add(Items.Strings[i]);
OutList.Assign(TPL);
finally
TPL.free;
end;
end;
>> J'ai mis le sender sur le CheckAll pour pouvoir l'appeler directement avec le click sur le menuitem "Tout cocher" mais peut etre qu'il y a un autre moyen ?
pas besoin, Tu crée la methode "TouCocher1Click" et tu place le code CheckList.CheckAll;
dedans.
ce serat plus propre car comme je te l'ai dis, ce sont des methodes et non des evenements. nuance.
en plus, cela permet de ne pas passer un argument inutile aux methodes ...
car un il ne faut pas oublier qu'un argument inutile prend de la place pour rien en memoire.
donc tu auras :
procedure TForm1.ToutCocher1Click(Sender : TObject);
begin
CheckList.CheckAll;
end;
et non dans l'inspecteur d'objet :
OnClick >> CheckList.CheckAll
21 avril 2006 à 10:47
Repeat Until execute l'instruction qu'elle contient au moins une fois meme si l'expression est fausse ... ce qui peu provoquer des erreurs si on ne control pas avant l'entrée dans la boucle.
While Do n'execute l'instruction qu'elle contient que si et seulement si l'expression est vraie. CAD, il faut que l'expression soit vraie dés le depart pour pourvoir rentrer dans la boucle.
avantage de Repeat Until c'est qu'on ne repete pas non plus le code pour FindFirst vus qu'on entre au moins une fois dans le Repeat Until, donc le premier elements trouver est toujours traiter, sauf si bien sur FindFirst <> 0 dans la condition If ...
par contre la ou je ne suis pas vraiment d'accord, c'est qu'un FindFirst,FindNext doit etre toujours dans un Try et FindClose dans le Finally vus que FindClose libere la memoire alloué par FinFirst ET FindNext ... et en cas d'erreur (on ne sait jamais) FindClose serat toujours executé.
procedure FindClose(var F: TSearchRec);
begin
{$IFDEF MSWINDOWS}
if F.FindHandle <> INVALID_HANDLE_VALUE then
begin
Windows.FindClose(F.FindHandle);
F.FindHandle := INVALID_HANDLE_VALUE;
end;
{$ENDIF}
{$IFDEF LINUX}
if F.FindHandle <> nil then
begin
closedir(F.FindHandle);
F.FindHandle := nil;
end;
{$ENDIF}
end;
meme si FindFirst et FindNext ne sont pas executé FindClose ne provoque pas d'erreur (<> INVALID_HANDLE_VALUE)
...
procedure Find(FilePath : string; List : TStrings);
var Rec : TSearchRec;
TLS : TStringList;
begin
try
TLS := TStringList.Create;
if FindFirst(FilePath,faAnyfile,Rec) = 0 then begin
repeat
TLS.Add(Rec.Name); // dans un repeat until cette ligne serait executée!!!
until FindNext(Rec) <> 0;
end;
List.Assign(TLS);
finally
FindClose(Rec);
TLS.Free;
end;
end;
tu as egalement raison sur les TStringList et tu me permet de corriger une erreur que je fais assé souvent d'ailleur, je t'en remercis.
procedure SetList(List : TStrings);
var TMPLIST : TStringList;
begin
try
TMPLIST := TStringList.Create;
...
TMPLIST.Add(...);
...
List.Assign(TMPLIST);
finally
TMPLIST.Free;
end;
end;
procedure AddToList(List : TStrings);
var TMPLIST : TStringList;
begin
try
TMPLIST := TStringList.Create;
...
TMPLIST.Add(...);
...
List.AddStrings(TMPLIST);
finally
TMPLIST.Free;
end;
end;
merci d'avoir corriger ce point important.
rappel : l'argument List ne doit pas etre declarer en Var ou Out ou encore Const si on veux pourvoir passé les propriétés de Type TStrings des composants dans les procedures.
Avantage du point que souleve Nono, c'est que si on ecrit tout de meme une fonction, elle permet de liberer la valeur du resultat pour passer un retour de control booléen ou tout autre retour.
exemple :
function AddToList(List : TStrings) : integer; // renvois ne nombre d'elements ajoutés
var TMPLIST : TStringList;
begin
result := 0;
try
TMPLIST := TStringList.Create;
...
TMPLIST.Add(...);
...
Result := TMPLIST.Count;
List.AddStrings(TMPLIST);
finally
TMPLIST.Free;
end;
end;
l'objet TMPLIST sert de buffer pour eviter de travailler directement sur un composant TListBox ou TMemo ou autre ... ce qui eviteras les "refresh" intempestif du composant qui vas de par le fait degrader fortement les performances.
voila voila, merci a nono.
21 avril 2006 à 10:10
Merci pour tes remarques et suggestions.
J'ai pas compris où est mon erreur sur le getselection ?
J'ai mis le sender sur le CheckAll pour pouvoir l'appeler directement avec le click sur le menuitem "Tout cocher" mais peut etre qu'il y a un autre moyen ?
Nono40 :
Désolé pour ma fonction moche... c'était un peu par flemme. Vu que je place à chaque fois la sélection dans un Tstrings local, j'évite de le creer et il se libère tout seul à la fin de la procédure... c'est vrai que c'est pas joli joli...
21 avril 2006 à 00:10
If FindFirst()=0 Then
Begin
Repeat
// Le code de gestion d'une occurence ici et seulement ici
Until FindNext()<>0;
FindClose()
End;
Le deuxième truc encore plus moche c'est le GetSelection:TStringList. Une grosse fuite de mémoire en perpective car il faut détruire la liste retournée par la fonction ce que personne ne fera... Regarde dans le code de la VCL pour voir comment sont gérées les propriétés de type TStrings. Ta méthode ne gère pas non plus les éventuelles erreur de durant le code entre la création de la liste et sa destruction.
Si vraiment tu veux faire une fonction que retourne un TStrings il faut faire comme suit :
Proceudre GetSelection(Selection:TStrings);
Begin
// Pas de create ici
End;
L'appel :
MaListe := TStringList.Create;
Try
GetSelection(MaListe);
// Traitement de la liste
Finally
MaListe.Free;
End;
20 avril 2006 à 18:33
function TCheckListBox.GetSelection : TStringList;
var
i : Integer;
begin
Result := TStringList.Create;
For i := 0 to Items.Count - 1 do
if Checked[i] then Result.Add(Items.Strings[i]);
end;
le retour peut etre en TStringList c'est mieux de faire ainsi.
petit renomage aussi elle devrait plutot s'appelée GetCheckeds et non GetSelection.
Selection c'est pour les elements Selectionné (highlight) et non Cochés (checked)
tu pourrais egalement ajouter une petit fonction du meme ordre que CheckAll ou UncheckAll :
procedure TCheckListBox.SwapCheck;
var
i : Integer;
begin
if Items.Count > 0 then begin
For i := 0 to Items.Count - 1 do Checked[i] := not Checked[i];
end;
Click;
end;
ce qui auras pour effet d'inverser la selection, peut etre trés pratique.
d'ailleur ces methodes n'ont pas besoin de (Sender : TObject) vus que ce ne sont pas des evenements mais bel et bien des methodes simple.
pour ta methode :
function IsFile(R : TSearchRec) : boolean;
begin
result := (not (R.Attr and 16)) and (not (R.Attr and 8)) and
(R.Name <> '.') and (R.Name <> '..');
end;
voilou...
procedure TFDepart.JVDL1Change(Sender: TObject);
var
MyList : TStringlist;
Rech : TSearchRec;
Begin
MyList := TStringList.Create;
// les fichiers, c'est sensible alors on traite en bloc Try .. Finally..
Try
if findFirst(JVDL1.Directory + '\*.*', faAnyFile, Rech) = 0 then
if IsFile(Rech) then MyList.Add(Rech.Name);
while FindNext(rech) = 0 do Begin
if IsFile(Rech) then MyList.Add(Rech.Name);
End;
finally
SysUtils.FindClose(Rech); // par precaussion on force SysUtils.FindClose
end;
CLB_Fich.Items.Assign(MyList); // ecrase les anciennes données
CLB_Fich.CheckAll; // on a viré le sender qui sert a rien
MyList.Free;
end;