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 :
unit BactBar;
interface
uses
Windows, Messages, SysUtils, Classes, Controls, Graphics, Dialogs;
type
TBarImgs=array [1..4] of TBitmap;
TBarStyle=(bbsNormal, bbsTransparent);
TBactBar = class(TGraphicControl)
private
{ Déclarations privées }
FBarImgs: TBarImgs;
FStyle: TBarStyle;
FPosition: Integer;
FMax: Integer;
FMin: Integer;
FColor: TColor;
protected
{ Déclarations protégées }
function OutBorderColor: TColor;
function BorderColor: TColor;
function InBorderColor: TColor;
procedure GetBarImgs;
procedure FreeBarImgs;
procedure GetFadedBar(Bitmap: TBitmap);
procedure GetNormalBar(Bitmap: TBitmap);
procedure SetPosition(Value: Integer);
procedure SetMin(Value: Integer);
procedure SetMax(Value: Integer);
procedure SetColor(Value: TColor);
procedure SetBarStyle(Value: TBarStyle);
function GetPosition: Integer;
function GetMin: Integer;
function GetMax: Integer;
function GetColor: TColor;
public
{ Déclarations publiques }
published
{ Déclarations publiées }
property BarColor: TColor read GetColor write SetColor;
property Style: TBarStyle read FStyle write SetBarStyle;
property Position: Integer read GetPosition write SetPosition;
property Min: Integer read GetMin write SetMin;
property Max: Integer read GetMax write SetMax;
property OnClick;
property OnContextPopup;
property OnDblClick;
property OnStartDrag;
property OnDragOver;
property OnEndDrag; // On remet tous les évenements hérités
property OnDragDrop;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property PopupMenu; // On remet le popupmenu
property ShowHint; // On remet ShowHint
property Visible; // On remet Visible
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure Paint; override;
end;
implementation
{$R BactBarImgs.res}
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;
constructor TBactBar.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
GetBarImgs;
FMax := 100;
FMin := 0;
FPosition := 50;
FColor := clLime;
Width := 150;
Height := 17;
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;
Bitmap.Canvas.Brush.Color := rgb(R, G, B);
Bitmap.Canvas.Pen.Color := rgb(R, G, B);
Bitmap.Canvas.Rectangle(0, 0, 1, Bitmap.Height);
Bitmap.Canvas.Pixels[0, 0] := BlendColors[3];
Bitmap.Canvas.Pixels[0, 1] := BlendColors[2];
Bitmap.Canvas.Pixels[0, 2] := BlendColors[1];
Bitmap.Canvas.Pixels[0, Bitmap.Height - 1] := BlendColors[3];
Bitmap.Canvas.Pixels[0, Bitmap.Height - 2] := BlendColors[2];
Bitmap.Canvas.Pixels[0, Bitmap.Height - 3] := BlendColors[1];
end;
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;
Bitmap.Canvas.Brush.Color := BarColor;
Bitmap.Canvas.Pen.Color := BarColor;
Bitmap.Canvas.Rectangle(0, 0, 1, Bitmap.Height);
Bitmap.Canvas.Pixels[0, 0] := BlendColors[3];
Bitmap.Canvas.Pixels[0, 1] := BlendColors[2];
Bitmap.Canvas.Pixels[0, 2] := BlendColors[1];
Bitmap.Canvas.Pixels[0, Bitmap.Height - 1] := BlendColors[3];
Bitmap.Canvas.Pixels[0, Bitmap.Height - 2] := BlendColors[2];
Bitmap.Canvas.Pixels[0, Bitmap.Height - 3] := BlendColors[1];
end;
procedure TBactBar.Paint;
Var
Bmp, BarBitmap: TBitmap;
Pos, MaxExt, PercentDone, Tmp, NbBars: Extended;
I: Integer;
P: TPoint;
begin
//////////////////////////////////////////////////////////////////////////////
//////////////////////////////////////////////////////////////////////////////
Pos := FPosition;
MaxExt := FMax;
PercentDone := (Pos / MaxExt) * 100;
Tmp := (Width / 100);
NbBars := PercentDone * Tmp;
// Calcul des valeurs
// Ici on dessine le composant
Bmp := TBitmap.Create;
Bmp.Width := Width - 1;
Bmp.Height := Height - 1;
Bmp.Canvas.Pen.Color := OutBorderColor;
Bmp.Canvas.Brush.Color := OutBorderColor;
Bmp.Canvas.FrameRect(Rect(Point(0, 0), Point(Width - 1, Height - 1)));
Bmp.Canvas.Pen.Color := BorderColor;
Bmp.Canvas.Brush.Color := BorderColor;
Bmp.Canvas.FrameRect(Rect(Point(1, 1), Point(Width - 2, Height - 2)));
Bmp.Canvas.Pen.Color := InBorderColor;
Bmp.Canvas.Brush.Color := InBorderColor;
Bmp.Canvas.FrameRect(Rect(Point(2, 2), Point(Width - 3, Height - 3)));
Bmp.Canvas.Draw(0, 0, FBarImgs[1]);
Bmp.Canvas.Draw(Width - 5, 0, FBarImgs[2]);
Bmp.Canvas.Draw(Width - 5, Height - 5, FBarImgs[3]);
Bmp.Canvas.Draw(0, Height - 5, FBarImgs[4]);
BarBitmap := TBitmap.Create;
GetFadedBar(BarBitmap);
Bmp.Canvas.Draw(3, 2, BarBitmap);
GetNormalBar(BarBitmap);
for I := 2 to Round(NbBars) - 1 do
begin
Bmp.Canvas.Draw(I + 2, 2, BarBitmap);
end;
GetFadedBar(BarBitmap);
Bmp.Canvas.Draw(Round(NbBars) + 2, 2, BarBitmap);
P := ClientToScreen(Point(0, 0));
Bmp.Canvas.Pixels[0, 0] := DesktopPixel(P.X, P.Y);
P := ClientToScreen(Point(0, Height - 2));
Bmp.Canvas.Pixels[0, Height - 2] := DesktopPixel(P.X, P.Y);
P := ClientToScreen(Point(Width - 2, 0));
Bmp.Canvas.Pixels[Width - 2, 0] := DesktopPixel(P.X, P.Y);
P := ClientToScreen(Point(Width - 2, Height - 2));
Bmp.Canvas.Pixels[Width - 2, Height - 2] := DesktopPixel(P.X, P.Y);
case Style of
bbsNormal: BitBlt(Canvas.Handle, 0, 0, Width, Height, Bmp.Canvas.Handle, 0, 0, SRCCOPY);
bbsTransparent: BitBlt(Canvas.Handle, 0, 0, Width, Height, Bmp.Canvas.Handle, 0, 0, SRCAND);
end;
Bmp.Free;
BarBitmap.Free;
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;
FBarImgs[1].LoadFromResourceName(HInstance, 'TOPLEFT');
FBarImgs[2].LoadFromResourceName(HInstance, 'TOPRIGHT');
FBarImgs[3].LoadFromResourceName(HInstance, 'BOTTOMRIGHT');
FBarImgs[4].LoadFromResourceName(HInstance, 'BOTTOMLEFT');
end;
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.
Bizarre non ?
Personne n'aurait une idée ?
Cordialement, Bacterius !