Bacterius
Messages postés3792Date d'inscriptionsamedi 22 décembre 2007StatutMembreDernière intervention 3 juin 2016
-
1 oct. 2008 à 20:54
Bacterius
Messages postés3792Date d'inscriptionsamedi 22 décembre 2007StatutMembreDernière intervention 3 juin 2016
-
2 oct. 2008 à 17:04
Bonsoir,
voici un cas fort interessant ... et bizarre.
Je prépare un composant graphique descendant de TGraphicControl, une sorte de progressbar pour tout vous dire ^^
Malheureusement, je rencontre un problème que je ne rencontre nulle part ailleurs :
---------------------------
Notification d'une exception du débogueur
---------------------------
Le projet Project1.exe a provoqué une classe d'exception EReadError avec le message 'La propriété BarColor n'existe pas'. Processus stoppé. Utilisez Pas-à-pas ou Exécuter pour continuer.
---------------------------
OK Aide
---------------------------
Je vous lance le code, il n'est pas trop optimisé, j'avais l'intention de résoudre ce bug avant de lancer l'optimisation, mais je n'y arrivais pas. Donc :
function DesktopPixel(X,Y:Integer):TColor;
var
Dc : HDC;
Begin
DC := CreateDC('DISPLAY',Nil,Nil,Nil);
Try
Result:=GetPixel(DC,X,Y);
Finally
DeleteDc(DC);
End;
End;
destructor TBactBar.Destroy;
begin
FreeBarImgs;
inherited Destroy;
end;
procedure TBactBar.GetFadedBar(Bitmap: TBitmap);
Var
R, G, B, I: Integer;
BlendColors: array [1..3] of TColor;
begin
Bitmap.Width := 1;
Bitmap.Height := Height - 5;
for I := 1 to 3 do
begin
R := GetRValue(BarColor) + I * 50;
G := GetGValue(BarColor) + I * 50;
B := GetBValue(BarColor) + I * 50;
R := R + 80;
G := G + 80;
B := B + 80;
if R < 0 then R := 0;
if R > 255 then R := 255;
if G < 0 then G := 0;
if G > 255 then G := 255;
if B < 0 then B := 0;
if B > 255 then B := 255;
BlendColors[I] := rgb(R, G, B);
end;
R := GetRValue(FColor) + 80;
G := GetGValue(FColor) + 80;
B := GetBValue(FColor) + 80;
if R < 0 then R := 0;
if R > 255 then R := 255;
if G < 0 then G := 0;
if G > 255 then G := 255;
if B < 0 then B := 0;
if B > 255 then B := 255;
procedure TBactBar.GetNormalBar(Bitmap: TBitmap);
Var
R, G, B, I: Integer;
BlendColors: array [1..3] of TColor;
begin
Bitmap.Width := 1;
Bitmap.Height := Height - 5;
for I := 1 to 3 do
begin
R := GetRValue(BarColor) + I * 50;
G := GetGValue(BarColor) + I * 50;
B := GetBValue(BarColor) + I * 50;
if R < 0 then R := 0;
if R > 255 then R := 255;
if G < 0 then G := 0;
if G > 255 then G := 255;
if B < 0 then B := 0;
if B > 255 then B := 255;
BlendColors[I] := rgb(R, G, B);
end;
procedure TBactBar.SetPosition(Value: Integer);
begin
if not (Value in [FMin..FMax]) then
raise Exception.Create('Position est en dehors de l''intervalle Min..Max');
FPosition := Value;
Invalidate;
end;
procedure TBactBar.SetMin(Value: Integer);
begin
if not (FPosition in [Value..FMax]) then
FPosition := Value;
FMin := Value;
Invalidate;
end;
procedure TBactBar.SetMax(Value: Integer);
begin
if not (FPosition in [FMin..Value]) then
FPosition := Value;
FMax := Value;
Invalidate;
end;
procedure TBactBar.SetColor(Value: TColor);
begin
if FColor <> Value then
begin
FColor := Value;
Invalidate;
end;
end;
procedure TBactBar.SetBarStyle(Value: TBarStyle);
begin
if FStyle <> Value then
begin
FStyle := Value;
Invalidate;
end;
end;
function TBactBar.GetPosition: Integer;
begin
Result := FPosition;
end;
function TBactBar.GetMax: Integer;
begin
Result := FMax;
end;
function TBactBar.GetMin: Integer;
begin
Result := FMin;
end;
function TBactBar.GetColor: TColor;
begin
Result := FColor;
end;
function TBactBar.OutBorderColor: TColor;
begin
Result := rgb(104, 104, 104);
end;
function TBactBar.BorderColor: TColor;
begin
Result := rgb(190, 190, 190);
end;
function TBactBar.InBorderColor: TColor;
begin
Result := rgb(239, 239, 239);
end;
procedure TBactBar.GetBarImgs;
Var
I: Byte;
begin
for I := Low(FBarImgs) to High(FBarImgs) do FBarImgs[I] := TBitmap.Create;
procedure TBactBar.FreeBarImgs;
Var
I: Byte;
begin
for I := Low(FBarImgs) to High(FBarImgs) do FBarImgs[I].Free;
end;
_________________
Cette erreur se produit lors de l'execution du projet (qui contient 1 instance de mon composant ...).
Elle se reproduit pour Position, Min, Max et Style.
WhiteHippo
Messages postés1154Date d'inscriptionsamedi 14 août 2004StatutMembreDernière intervention 5 avril 20123 1 oct. 2008 à 21:17
Déjà la première chose qui saute aux yeux :
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure Paint; override;
dans la section published !!!!!
Déplace les dans la section public pour commencer.
Cordialement.
<hr />"L'imagination est plus importante que le savoir." Albert Einstein
WhiteHippo
Messages postés1154Date d'inscriptionsamedi 14 août 2004StatutMembreDernière intervention 5 avril 20123 1 oct. 2008 à 21:50
J'ai pas été assez clair. Quand je dis que pas de problèmes c'est que tout est ok : compilation du paquet, utilisation du composant, compilation de l'exe et execution.
Cordialement.
<hr />"L'imagination est plus importante que le savoir." Albert Einstein
WhiteHippo
Messages postés1154Date d'inscriptionsamedi 14 août 2004StatutMembreDernière intervention 5 avril 20123 1 oct. 2008 à 22:08
Ce serait bien d'expliquer ce qui n'allait pas dans ta procédure register au cas où quelqu'un aurait le même problème (sans oublier en même temps de valider ton explication)
Cordialement.
<hr />"L'imagination est plus importante que le savoir." Albert Einstein
Vous n’avez pas trouvé la réponse que vous recherchez ?
Guillemouze
Messages postés991Date d'inscriptionsamedi 25 octobre 2003StatutMembreDernière intervention29 août 20136 1 oct. 2008 à 22:47
petite supposition :
n'as tu pas 2 fois la meme unité a des endroits differents?
ce que je suppose :
tu install ton package, tu pose ton composant sur ta fiche, et tu sauve ton projet : le dfm est créé et contient les lignes suivantes :
object BactBar1: TBactBar
position: 50
...
end
ensuite tu compile ton projet, et là, c'est une autre occurence de ton unité qui est compilé, qui ne contient pas Position dans la section published
quand tu execute, le createForm va lire le dfm dans ses resources, et essaye d'affecter les valeurs stockées aux proprietes published de ton objet compilé ... qui ne contient pas Position => EReadError.
Si tu n'as pas 2 fichiers, alors c'est peut etre que ton delphi deconne et qu'il a gardé en memoire une ancienne version de ton unité qu'il utilise au moment de la compilation. Dans ce cas, un reinstallation s'impose peut etre
f0xi
Messages postés4205Date d'inscriptionsamedi 16 octobre 2004StatutModérateurDernière intervention12 mars 202235 2 oct. 2008 à 02:58
{ Definition pour la compilation conditionnelle.
Utiliser un nouvel IDE Delphi (2005 et plus) permet de faire
du code plus souple et performant que sur les anciennes versions.
}
type
TBarImgs = array [0..3] of TBitmap; // on commence toujours a 0 c'est mieux!
const
{ Nom prédéfinit des ressources bitmap.
aurait du etre :
BITOPLEFT, BITOPRIGHT, BIBOTTOMRIGHT, BIBOTTOMLEFT
ou mieux :
BARIMGTL, BARIMGTR, BARIMGBR, BARIMGBL
Toujours nomer les ressources en fonctions du nom des variables
qui les récéptionnes.
}
BarImgsResourceName : array[Low(TBarImgs)..High(TBarImgs)] of string = (
'TOPLEFT','TOPRIGHT','BOTTOMRIGHT','BOTTOMLEFT'
);
type
TBarStyle = (bbsNormal, bbsTransparent);
TBactBar = class(TGraphicControl)
private
FBarImgs : TBarImgs;
FColor : TColor;
FStyle : TBarStyle;
FPosition : Integer;
FMin : Integer;
FMax : Integer;
procedure SetColor(Value: TColor);
procedure SetBarStyle(Value: TBarStyle);
procedure SetPMM(index: integer;Value: Integer); // voir l'implementation ...
protected
procedure Paint; override;
protected
{$IFDEF NEWDELPHI}
{ apprendre a programmer avec les nouveautés de Delphi
evite des "call" inutiles qui ralentissents de maniere significative
l'affichage des objets visuel.
}
const OutBorderColor: TColor = $00686868;
const BorderColor : TColor = $00BEBEBE;
const InBorderColor : TColor = $00EFEFEF;
{$ELSE}
function OutBorderColor: TColor;
function BorderColor: TColor;
function InBorderColor: TColor;
{$ENDIF}
procedure GetFadedBar(Bitmap: TBitmap);
procedure GetNormalBar(Bitmap: TBitmap);
published
property BarColor : TColor read FColor write SetColor default clLime;
property Style : TBarStyle read FStyle write SetBarStyle default bbsNormal;
property Position : Integer index 0 read FPosition write SetPMM default 50;
property Min : Integer index 1 read FMin write SetPMM default 0;
property Max : Integer index 2 read FMax write SetPMM default 100;
published // pas besoin de justifier pourquoi on rend visible les evenements ou propriétés herités.
property OnClick;
property OnContextPopup;
property OnDblClick;
property OnStartDrag;
property OnDragOver;
property OnEndDrag;
property OnDragDrop;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property PopupMenu;
property ShowHint;
property Visible;
public // Create et Destroy sont toujours public, comme toutes fonctions ou procedures devant etre visible
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
end;
function ColorRefToColor(WinColor: ColorRef): TColor;
asm
// Transformation :
// EAX = A R G B
BSWAP EAX; // EAX = B G R A MOV AL, $00; // EAX B G R A (A $00)
ROR EAX, $08; // EAX = A B G R
end;
function ColorToColorRef(DelphiColor: TColor): ColorRef;
asm
// Transformation :
// EAX = A B G R
BSWAP EAX; // EAX = R G B A MOV AL, $FF; // EAX R G B A (A $FF)
ROR EAX, $08; // EAX = A R G B
end;
function DesktopPixel(X,Y:Integer):TColor;
var
DC : HDC;
CR : ColorRef;
Begin
DC := CreateDC('DISPLAY',Nil,Nil,Nil);
Try
{ <!> attention, renvois ColorRef (RGB) et non TColor (BGR) }
result := ColorRefToColor(GetPixel(DC, X, Y));
Finally
DeleteDc(DC);
End;
End;
// Plus simple
for I := Low(TBarImgs) to High(TBarImgs) do
begin
FBarImgs[I] := TBitmap.Create;
FBarImgs[I].LoadFromResourceName(HInstance, BarImgsResourceName[I]);
end;
end;
destructor TBactBar.Destroy;
var
I: integer;
begin
// Liberation ... a l'envers!
// Premier créé, dernier libéré!
for I := High(FBarImgs) downto Low(FBarImgs) do
FBarImgs[I].Free;
inherited Destroy;
end;
procedure TBactBar.GetFadedBar(Bitmap: TBitmap);
Var
R, G, B, I: Integer;
BPCol : TColor;
BlendColors: array [1..3] of TColor;
begin
if (not Assigned(Bitmap)) or (Bitmap = nil) then
exit;
Bitmap.Width := 1;
Bitmap.Height := Height - 5;
for I := 1 to 3 do
begin
R := byte(FColor) + I * 50;
G := byte(FColor shr 8) + I * 50;
B := byte(FColor shr 16) + I * 50;
R := R + 80;
G := G + 80;
B := B + 80;
if R < 0 then R := 0 else if R > 255 then R := 255;
if G < 0 then G := 0 else if G > 255 then G := 255;
if B < 0 then B := 0 else if B > 255 then B := 255;
BlendColors[I] := byte(R) or (byte(G) shl 8) or (byte(B) shl 16);
end;
R := byte(FColor) + 80;
G := byte(FColor shr 8) + 80;
B := byte(FColor shr 16) + 80;
if R < 0 then R := 0 else if R > 255 then R := 255;
if G < 0 then G := 0 else if G > 255 then G := 255;
if B < 0 then B := 0 else if B > 255 then B := 255;
BPCol := byte(R) or (byte(G) shl 8) or (byte(B) shl 16);
procedure TBactBar.GetNormalBar(Bitmap: TBitmap);
Var
R, G, B, I: Integer;
BlendColors: array [1..3] of TColor;
begin
if (not Assigned(Bitmap)) or (Bitmap = nil) then
exit;
Bitmap.Width := 1;
Bitmap.Height := Height - 5;
for I := 1 to 3 do
begin
R := byte(FColor) + I * 50;
G := byte(FColor shr 8) + I * 50;
B := byte(FColor shr 16) + I * 50;
if R < 0 then R := 0 else if R > 255 then R := 255;
if G < 0 then G := 0 else if G > 255 then G := 255;
if B < 0 then B := 0 else if B > 255 then B := 255;
BlendColors[I] := byte(R) or (byte(G) shl 8) or (byte(B) shl 16);
end;
//for I := 2 to NbBars-1 do
// Bmp.Canvas.Draw(I+2, 2, BarBitmap);
NbBars := round((Width/FMax)*FPosition)-1;
if NbBars > (Width-5) then
NbBars := Width-5;
if NbBars > 0 then
StretchBlt(Bmp.Canvas.Handle, 2, 2, NbBars, Bmp.Height-4,
BarBitmap.Canvas.Handle, 0, 0, BarBitmap.Width, BarBitmap.Height, SRCCOPY);
procedure TBactBar.SetPMM(Index: integer; Value: Integer);
var ptr: ^integer;
begin
// SetPosition, SetMin et SetMax au seins d'une même fonction!
// Plus pratique puisque les trois variables sont dependantes...
case index of
0 : ptr := @FPosition;
1 : ptr := @FMin;
2 : ptr := @FMax;
end;
if Value <> ptr^ then
begin
ptr^ := Value;
case index of
1 : if FMin >= FMax then
FMax := FMin + 10;
2 : if FMax <= FMin then
FMin := FMax - 10;
end;
if FPosition > FMax then
FPosition := FMax
else
if FPosition < FMin then
FPosition := FMin;
Invalidate;
end;
end;
procedure TBactBar.SetColor(Value: TColor);
begin
if FColor <> Value then
begin
FColor := Value;
Invalidate;
end;
end;
procedure TBactBar.SetBarStyle(Value: TBarStyle);
begin
if FStyle <> Value then
begin
FStyle := Value;
Invalidate;
end;
end;
{$IFDEF NEWDELPHI}
{$ELSE}
function TBactBar.OutBorderColor: TColor;
begin
// Hardcoded color ... evite un Call sur RGB
Result := $00686868;
end;
function TBactBar.BorderColor: TColor;
begin
// Hardcoded color ... evite un Call sur RGB
Result := $00BEBEBE;
end;
function TBactBar.InBorderColor: TColor;
begin
// Hardcoded color ... evite un Call sur RGB
Result := $00EFEFEF;
end;
{$ENDIF}
Bacterius
Messages postés3792Date d'inscriptionsamedi 22 décembre 2007StatutMembreDernière intervention 3 juin 201610 2 oct. 2008 à 17:04
Ben en fait dans l'unité ComponentReg, j'avais dans les uses toutes les unités des compos, et je faisais ainsi :
uses Comp1, Comp2, etc ...;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Bacterius', [TComp1, TComp2, etc ...]);
end;
Ca ne marchait pas, alors j'ai remis une procédure Register dans chaque composant et c'est réparé.
Par contre, attention :
chez moi (Delphi 6) il faut mettre une majuscule à Register, sinon ça n'installera pas le composant ...
@F0xi : merci pour l'optimisation, je ne pense pas tout prendre dedans mais il y a des choses interessantes ... justement dans les fonctions constantes de couleur, merci d'avoir donné les codes couleur windows, ça m'a évité d'aller les chercher :)
Et pour l'asm et les SHL, je vais voir.
Sinon, juste une question : pourquoi tu les libères à l'envers ? c'est une convention ?
Bacterius
Messages postés3792Date d'inscriptionsamedi 22 décembre 2007StatutMembreDernière intervention 3 juin 201610 1 oct. 2008 à 21:42
C'est pas de la compilation.
En fait, ca compile bien.
Mais, si je crée une nouvelle application.
Je pose le composant n'importe-ou.
Pas de problème.
J'execute.
Hop ! erreur de lecture de flux.
Bacterius
Messages postés3792Date d'inscriptionsamedi 22 décembre 2007StatutMembreDernière intervention 3 juin 201610 1 oct. 2008 à 21:49
Ah ah retournement de situation.
Je supprime ce composant du paquet, je l'installe dans un autre et ça marche.
Résultat : mon paquet est corrompu.
(Ou alors c'est la procédure Register qui fait beuger, j'ai dû l'ajouter dans le code pour le nouveau paquet, dans mon ancien paquet j'avais une unité pour tous les recenser ...)